diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1f9768a6a8..befac14642 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -31,7 +31,7 @@ setup: # Clone regressions directory - git clone --recursive http://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git tests && cd tests # Install / update testing scripts - - git clone https://github.com/adcroft/MRS.git MRS + - git clone -b new-code-struct https://github.com/adcroft/MRS.git MRS # Update MOM6-examples and submodules - (cd MOM6-examples && git checkout . && git checkout dev/gfdl && git pull && git submodule init && git submodule update) - (cd MOM6-examples/src/MOM6 && git submodule update) @@ -60,7 +60,7 @@ gnu:ocean-only-nolibs: - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - make -f MRS/Makefile.build build/gnu/env && cd build/gnu # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only - - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{solo_driver,dynamic_symmetric,ext*} ../../../src ../../MOM6-examples/src/FMS + - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{drivers/solo_driver,memory/dynamic_symmetric,infra/FMS1,ext*} ../../../src ../../MOM6-examples/src/FMS - sed -i '/FMS\/.*\/test_/d' path_names - ../../MOM6-examples/src/mkmf/bin/mkmf -t ../../MOM6-examples/src/mkmf/templates/ncrc-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF" path_names - time (source ./env ; make NETCDF=3 REPRO=1 MOM6 -s -j) @@ -73,7 +73,7 @@ gnu:ice-ocean-nolibs: - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - make -f MRS/Makefile.build build/gnu/env && cd build/gnu # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only - - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{coupled_driver,dynamic,ext*} ../../../src ../../MOM6-examples/src/{FMS,coupler,SIS2,icebergs,ice_param,land_null,atmos_null} + - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{drivers/FMS_cap,memory/dynamic_nonsymmetric,infra/FMS1,ext*} ../../../src ../../MOM6-examples/src/{FMS,coupler,SIS2,icebergs,ice_param,land_null,atmos_null} - sed -i '/FMS\/.*\/test_/d' path_names - ../../MOM6-examples/src/mkmf/bin/mkmf -t ../../MOM6-examples/src/mkmf/templates/ncrc-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names - time (source ./env ; make NETCDF=3 REPRO=1 MOM6 -s -j) diff --git a/.testing/Makefile b/.testing/Makefile index 2806d54130..02f6557c09 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -32,7 +32,6 @@ # MPIFC MPI Fortran compiler # # Build configuration: -# # FCFLAGS_DEBUG Testing ("debug") compiler flags # FCFLAGS_REPRO Production ("repro") compiler flags # FCFLAGS_INIT Variable initialization flags @@ -76,7 +75,6 @@ FCFLAGS_REPRO ?= -g -O2 FCFLAGS_INIT ?= FCFLAGS_COVERAGE ?= # Additional notes: -# # - The default values are simple, minimalist flags, supported by nearly all # compilers which are comparable to GFDL's canonical DEBUG and REPRO builds. # @@ -86,14 +84,18 @@ FCFLAGS_COVERAGE ?= # - FMS cannot be built with the same aggressive initialization flags as MOM6, # so FCFLAGS_INIT is used to provide additional MOM6 configuration. +# User-defined LDFLAGS (applied to all builds and FMS) +LDFLAGS_USER ?= + # Set to `true` to require identical results from DEBUG and REPRO builds +# NOTE: Many compilers (Intel, GCC on ARM64) do not yet produce identical +# results across DEBUG and REPRO builds (as defined below), so we disable on +# default. DO_REPRO_TESTS ?= +# Time measurement (configurable by the CI) TIME ?= time -# Many compilers (Intel, GCC on ARM64) do not yet produce identical results -# across DEBUG and REPRO builds (as defined below), so we disable on default. - #--- # Dependencies DEPS = deps @@ -154,10 +156,12 @@ SOURCE = \ $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) MOM_SOURCE = $(call SOURCE,../src) \ - $(wildcard ../config_src/solo_driver/*.F90) \ + $(wildcard ../config_src/infra/FMS1/*.F90) \ + $(wildcard ../config_src/drivers/solo_driver/*.F90) \ $(wildcard ../config_src/ext*/*/*.F90) TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ - $(wildcard build/target_codebase/config_src/solo_driver/*.F90) \ + $(wildcard build/target_codebase/config_src/infra/FMS1/*.F90) \ + $(wildcard build/target_codebase/config_src/drivers/solo_driver/*.F90) \ $(wildcard build/target_codebase/config_src/ext*/*.F90) FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) @@ -216,8 +220,8 @@ REPRO_FCFLAGS := FCFLAGS="$(FCFLAGS_REPRO) $(FCFLAGS_FMS)" OPENMP_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" TARGET_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" -MOM_LDFLAGS := LDFLAGS="$(LDFLAGS_FMS)" -SYMMETRIC_LDFLAGS := LDFLAGS="$(COVERAGE) $(LDFLAGS_FMS)" +MOM_LDFLAGS := LDFLAGS="$(LDFLAGS_FMS) $(LDFLAGS_USER)" +SYMMETRIC_LDFLAGS := LDFLAGS="$(COVERAGE) $(LDFLAGS_FMS) $(LDFLAGS_USER)" # Environment variable configuration @@ -249,7 +253,7 @@ build/target/Makefile: | $(TARGET_CODEBASE) # Ideally we would want to re-run both Makefile and mkmf, but our mkmf call # is inside ./configure, so we must re-run ./configure as well. $(foreach b,$(filter-out target,$(BUILDS)),build/$(b)/Makefile): $(MOM_SOURCE) -build/target/configure: $(TARGET_SOURCE) +build/target_codebase/configure: $(TARGET_SOURCE) # Build MOM6 @@ -285,10 +289,7 @@ $(TARGET_CODEBASE)/ac/configure: $(TARGET_CODEBASE) $(TARGET_CODEBASE): git clone --recursive $(MOM_TARGET_URL) $@ - cd $@ && git checkout $(MOM_TARGET_BRANCH) - # Copy modern autoconf files to target? - mkdir -p $(TARGET_CODEBASE)/ac - cp -r ../ac/{configure.ac,Makefile.in,m4} $(TARGET_CODEBASE)/ac + cd $@ && git checkout --recurse-submodules $(MOM_TARGET_BRANCH) #--- diff --git a/ac/configure.ac b/ac/configure.ac index 487230beb8..6ff4ae5e8b 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -42,18 +42,18 @@ srcdir=$srcdir/.. # Default to symmetric grid # NOTE: --enable is more properly used to add a feature, rather than to select # a compile-time mode, so this is not exactly being used as intended. -MEM_LAYOUT=${srcdir}/config_src/dynamic_symmetric +MEM_LAYOUT=${srcdir}/config_src/memory/dynamic_symmetric AC_ARG_ENABLE([asymmetric], AS_HELP_STRING([--enable-asymmetric], [Use the asymmetric grid])) AS_IF([test "$enable_asymmetric" = yes], - [MEM_LAYOUT=${srcdir}/config_src/dynamic]) + [MEM_LAYOUT=${srcdir}/config_src/memory/dynamic_nonsymmetric]) # Default to solo_driver -DRIVER_DIR=${srcdir}/config_src/solo_driver +DRIVER_DIR=${srcdir}/config_src/drivers/solo_driver AC_ARG_WITH([driver], AS_HELP_STRING([--with-driver=coupled_driver|solo_driver], [Select directory for driver source code])) AS_IF([test "x$with_driver" != "x"], - [DRIVER_DIR=${srcdir}/config_src/${with_driver}]) + [DRIVER_DIR=${srcdir}/config_src/drivers/${with_driver}]) # TODO: Rather than point to a pre-configured header file, autoconf could be # used to configure a header based on a template. @@ -216,6 +216,7 @@ AS_IF([test -z "$MKMF"], [ AC_CONFIG_COMMANDS([path_names], [list_paths -l \ ${srcdir}/src \ + ${srcdir}/config_src/infra/FMS1 \ ${srcdir}/config_src/ext* \ ${DRIVER_DIR} \ ${MEM_LAYOUT} diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 similarity index 97% rename from config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 rename to config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index bb89c4e85e..871368fc73 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -36,6 +36,7 @@ module MOM_surface_forcing_gfdl use MOM_variables, only : surface use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS +use iso_fortran_env, only : int64 implicit none ; private @@ -1622,32 +1623,39 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) type(ice_ocean_boundary_type), & intent(in) :: iobt !< An ice-ocean boundary type with fluxes to drive the !! ocean in a coupled model whose checksums are reported - integer :: n,m, outunit + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to outunit = stdout - - write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(outunit,100) 'iobt%u_flux ', field_chksum( iobt%u_flux ) - write(outunit,100) 'iobt%v_flux ', field_chksum( iobt%v_flux ) - write(outunit,100) 'iobt%t_flux ', field_chksum( iobt%t_flux ) - write(outunit,100) 'iobt%q_flux ', field_chksum( iobt%q_flux ) - write(outunit,100) 'iobt%salt_flux ', field_chksum( iobt%salt_flux ) - write(outunit,100) 'iobt%lw_flux ', field_chksum( iobt%lw_flux ) - write(outunit,100) 'iobt%sw_flux_vis_dir', field_chksum( iobt%sw_flux_vis_dir) - write(outunit,100) 'iobt%sw_flux_vis_dif', field_chksum( iobt%sw_flux_vis_dif) - write(outunit,100) 'iobt%sw_flux_nir_dir', field_chksum( iobt%sw_flux_nir_dir) - write(outunit,100) 'iobt%sw_flux_nir_dif', field_chksum( iobt%sw_flux_nir_dif) - write(outunit,100) 'iobt%lprec ', field_chksum( iobt%lprec ) - write(outunit,100) 'iobt%fprec ', field_chksum( iobt%fprec ) - write(outunit,100) 'iobt%runoff ', field_chksum( iobt%runoff ) - write(outunit,100) 'iobt%calving ', field_chksum( iobt%calving ) - write(outunit,100) 'iobt%p ', field_chksum( iobt%p ) - if (associated(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ', field_chksum( iobt%ustar_berg ) - if (associated(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ', field_chksum( iobt%area_berg ) - if (associated(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ', field_chksum( iobt%mass_berg ) + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + chks = field_chksum( iobt%u_flux ) ; if (root) write(outunit,100) 'iobt%u_flux ', chks + chks = field_chksum( iobt%v_flux ) ; if (root) write(outunit,100) 'iobt%v_flux ', chks + chks = field_chksum( iobt%t_flux ) ; if (root) write(outunit,100) 'iobt%t_flux ', chks + chks = field_chksum( iobt%q_flux ) ; if (root) write(outunit,100) 'iobt%q_flux ', chks + chks = field_chksum( iobt%salt_flux ) ; if (root) write(outunit,100) 'iobt%salt_flux ', chks + chks = field_chksum( iobt%lw_flux ) ; if (root) write(outunit,100) 'iobt%lw_flux ', chks + chks = field_chksum( iobt%sw_flux_vis_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dir', chks + chks = field_chksum( iobt%sw_flux_vis_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dif', chks + chks = field_chksum( iobt%sw_flux_nir_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dir', chks + chks = field_chksum( iobt%sw_flux_nir_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dif', chks + chks = field_chksum( iobt%lprec ) ; if (root) write(outunit,100) 'iobt%lprec ', chks + chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks + chks = field_chksum( iobt%runoff ) ; if (root) write(outunit,100) 'iobt%runoff ', chks + chks = field_chksum( iobt%calving ) ; if (root) write(outunit,100) 'iobt%calving ', chks + chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks + if (associated(iobt%ustar_berg)) then + chks = field_chksum( iobt%ustar_berg ) ; if (root) write(outunit,100) 'iobt%ustar_berg ', chks + endif + if (associated(iobt%area_berg)) then + chks = field_chksum( iobt%area_berg ) ; if (root) write(outunit,100) 'iobt%area_berg ', chks + endif + if (associated(iobt%mass_berg)) then + chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 similarity index 98% rename from config_src/coupled_driver/ocean_model_MOM.F90 rename to config_src/drivers/FMS_cap/ocean_model_MOM.F90 index f635e886a5..c430623591 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -56,6 +56,7 @@ module ocean_model_mod use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves +use iso_fortran_env, only : int64 #include @@ -1094,25 +1095,29 @@ subroutine ocean_model_data1D_get(OS, Ocean, name, value) end subroutine ocean_model_data1D_get -!> Write out FMS-format checsums on fields from the ocean surface state +!> Write out checksums for fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) character(len=*), intent(in) :: id !< An identifying string for this call integer, intent(in) :: timestep !< The number of elapsed timesteps type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly !! visible ocean surface fields. - integer :: n, m, outunit + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to outunit = stdout - - write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(outunit,100) 'ocean%t_surf ', field_chksum(ocn%t_surf ) - write(outunit,100) 'ocean%s_surf ', field_chksum(ocn%s_surf ) - write(outunit,100) 'ocean%u_surf ', field_chksum(ocn%u_surf ) - write(outunit,100) 'ocean%v_surf ', field_chksum(ocn%v_surf ) - write(outunit,100) 'ocean%sea_lev ', field_chksum(ocn%sea_lev) - write(outunit,100) 'ocean%frazil ', field_chksum(ocn%frazil ) - write(outunit,100) 'ocean%melt_potential ', field_chksum(ocn%melt_potential) + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) @@ -1162,6 +1167,8 @@ subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) sfc_state => OS%sfc_state + call pass_vector(sfc_state%u, sfc_state%v, G%Domain) + select case(name) case('ua') do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd diff --git a/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 similarity index 100% rename from config_src/ice_solo_driver/atmos_ocean_fluxes.F90 rename to config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 similarity index 99% rename from config_src/ice_solo_driver/ice_shelf_driver.F90 rename to config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index bd64050a6f..959e4676d0 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -185,6 +185,8 @@ program Shelf_main endif endif + call Get_MOM_Input(param_file, dirs) + ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ice_solo.res')) then call open_ASCII_file(unit, trim(dirs%restart_input_dir)//'ice_solo.res', action=READONLY_FILE) @@ -215,7 +217,6 @@ program Shelf_main Start_time = real_to_time(0.0) endif - call Get_MOM_Input(param_file, dirs) ! Determining the internal unit scaling factors for this run. call unit_scaling_init(param_file, US) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 similarity index 98% rename from config_src/mct_driver/mom_ocean_model_mct.F90 rename to config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 5a04739971..bd6c7fe66e 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -15,6 +15,7 @@ module MOM_ocean_model_mct use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : get_ocean_stocks, step_offline +use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end @@ -65,6 +66,7 @@ module MOM_ocean_model_mct ! MCT specfic routines use MOM_domains, only : MOM_infra_end +use iso_fortran_env, only : int64 #include @@ -1042,24 +1044,26 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -!> Write out FMS-format checsums on fields from the ocean surface state +!> Write out checksums for fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) character(len=*), intent(in) :: id !< An identifying string for this call integer, intent(in) :: timestep !< The number of elapsed timesteps type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly !! visible ocean surface fields. - integer :: n, m - - write(stdout,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(stdout,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) - write(stdout,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) - write(stdout,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) - write(stdout,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) - write(stdout,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) - write(stdout,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) - write(stdout,100) 'ocean%melt_potential ',mpp_chksum(ocn%melt_potential) - + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks call coupler_type_write_chksums(ocn%fields, stdout, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 similarity index 95% rename from config_src/mct_driver/mom_surface_forcing_mct.F90 rename to config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 index 82105e040e..e2a557daff 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -2,7 +2,7 @@ module MOM_surface_forcing_mct ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : reproducing_sum +use MOM_coms, only : reproducing_sum, field_chksum use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT @@ -37,7 +37,8 @@ module MOM_surface_forcing_mct use mpp_mod, only : mpp_chksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init -use MOM_io, only: stdout +use MOM_io, only : stdout +use iso_fortran_env, only : int64 implicit none ; private @@ -486,17 +487,18 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! latent heat flux (W/m^2) fluxes%latent(i,j) = 0.0 - ! contribution from frozen ppt + ! contribution from frozen ppt (notice minus sign since fprec is positive into the ocean) if (associated(IOB%fprec)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + & + fluxes%latent(i,j) = fluxes%latent(i,j) - & IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = - G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif - ! contribution from frozen runoff + ! contribution from frozen runoff (notice minus sign since rofi_flux is positive into the ocean) if (associated(fluxes%frunoff)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + & + fluxes%latent(i,j) = fluxes%latent(i,j) - & IOB%rofi_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * IOB%rofi_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -G%mask2dT(i,j) & + * IOB%rofi_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif ! contribution from evaporation if (associated(IOB%q_flux)) then @@ -1361,32 +1363,40 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) !! ocean in a coupled model whose checksums are reported ! local variables - integer :: n,m - - write(stdout,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(stdout,100) 'iobt%u_flux ' , mpp_chksum( iobt%u_flux ) - write(stdout,100) 'iobt%v_flux ' , mpp_chksum( iobt%v_flux ) - write(stdout,100) 'iobt%t_flux ' , mpp_chksum( iobt%t_flux ) - write(stdout,100) 'iobt%q_flux ' , mpp_chksum( iobt%q_flux ) - write(stdout,100) 'iobt%salt_flux ' , mpp_chksum( iobt%salt_flux ) - write(stdout,100) 'iobt%seaice_melt_heat' , mpp_chksum( iobt%seaice_melt_heat) - write(stdout,100) 'iobt%seaice_melt ' , mpp_chksum( iobt%seaice_melt ) - write(stdout,100) 'iobt%lw_flux ' , mpp_chksum( iobt%lw_flux ) - write(stdout,100) 'iobt%sw_flux_vis_dir' , mpp_chksum( iobt%sw_flux_vis_dir) - write(stdout,100) 'iobt%sw_flux_vis_dif' , mpp_chksum( iobt%sw_flux_vis_dif) - write(stdout,100) 'iobt%sw_flux_nir_dir' , mpp_chksum( iobt%sw_flux_nir_dir) - write(stdout,100) 'iobt%sw_flux_nir_dif' , mpp_chksum( iobt%sw_flux_nir_dif) - write(stdout,100) 'iobt%lprec ' , mpp_chksum( iobt%lprec ) - write(stdout,100) 'iobt%fprec ' , mpp_chksum( iobt%fprec ) - write(stdout,100) 'iobt%runoff ' , mpp_chksum( iobt%runoff ) - write(stdout,100) 'iobt%calving ' , mpp_chksum( iobt%calving ) - write(stdout,100) 'iobt%p ' , mpp_chksum( iobt%p ) - if (associated(iobt%ustar_berg)) & - write(stdout,100) 'iobt%ustar_berg ' , mpp_chksum( iobt%ustar_berg ) - if (associated(iobt%area_berg)) & - write(stdout,100) 'iobt%area_berg ' , mpp_chksum( iobt%area_berg ) - if (associated(iobt%mass_berg)) & - write(stdout,100) 'iobt%mass_berg ' , mpp_chksum( iobt%mass_berg ) + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + outunit = stdout + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + chks = field_chksum( iobt%u_flux ) ; if (root) write(outunit,100) 'iobt%u_flux ', chks + chks = field_chksum( iobt%v_flux ) ; if (root) write(outunit,100) 'iobt%v_flux ', chks + chks = field_chksum( iobt%t_flux ) ; if (root) write(outunit,100) 'iobt%t_flux ', chks + chks = field_chksum( iobt%q_flux ) ; if (root) write(outunit,100) 'iobt%q_flux ', chks + chks = field_chksum( iobt%seaice_melt_heat); if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks + chks = field_chksum( iobt%seaice_melt) ; if (root) write(outunit,100) 'iobt%seaice_melt ', chks + chks = field_chksum( iobt%salt_flux ) ; if (root) write(outunit,100) 'iobt%salt_flux ', chks + chks = field_chksum( iobt%lw_flux ) ; if (root) write(outunit,100) 'iobt%lw_flux ', chks + chks = field_chksum( iobt%sw_flux_vis_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dir', chks + chks = field_chksum( iobt%sw_flux_vis_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dif', chks + chks = field_chksum( iobt%sw_flux_nir_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dir', chks + chks = field_chksum( iobt%sw_flux_nir_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dif', chks + chks = field_chksum( iobt%lprec ) ; if (root) write(outunit,100) 'iobt%lprec ', chks + chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks + chks = field_chksum( iobt%rofl_flux ) ; if (root) write(outunit,100) 'rofl_flux ', chks + chks = field_chksum( iobt%rofi_flux ) ; if (root) write(outunit,100) 'rofi_flux ', chks + chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks + if (associated(iobt%ustar_berg)) then + chks = field_chksum( iobt%ustar_berg ) ; if (root) write(outunit,100) 'iobt%ustar_berg ', chks + endif + if (associated(iobt%area_berg)) then + chks = field_chksum( iobt%area_berg ) ; if (root) write(outunit,100) 'iobt%area_berg ', chks + endif + if (associated(iobt%mass_berg)) then + chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, stdout, 'iobt%') diff --git a/config_src/mct_driver/ocn_cap_methods.F90 b/config_src/drivers/mct_cap/ocn_cap_methods.F90 similarity index 100% rename from config_src/mct_driver/ocn_cap_methods.F90 rename to config_src/drivers/mct_cap/ocn_cap_methods.F90 diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/drivers/mct_cap/ocn_comp_mct.F90 similarity index 100% rename from config_src/mct_driver/ocn_comp_mct.F90 rename to config_src/drivers/mct_cap/ocn_comp_mct.F90 diff --git a/config_src/mct_driver/ocn_cpl_indices.F90 b/config_src/drivers/mct_cap/ocn_cpl_indices.F90 similarity index 100% rename from config_src/mct_driver/ocn_cpl_indices.F90 rename to config_src/drivers/mct_cap/ocn_cpl_indices.F90 diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 similarity index 99% rename from config_src/nuopc_driver/mom_cap.F90 rename to config_src/drivers/nuopc_cap/mom_cap.F90 index f0ce8720bb..7dc95e13fa 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -75,6 +75,7 @@ module MOM_cap_mod use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite +use ESMF, only: ESMF_END_ABORT, ESMF_Finalize use ESMF, only: operator(==), operator(/=), operator(+), operator(-) ! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. @@ -135,6 +136,7 @@ module MOM_cap_mod logical :: profile_memory = .true. logical :: grid_attach_area = .false. logical :: use_coldstart = .true. +logical :: use_mommesh = .true. character(len=128) :: scalar_field_name = '' integer :: scalar_field_count = 0 integer :: scalar_field_idx_grid_nx = 0 @@ -147,7 +149,7 @@ module MOM_cap_mod type(ESMF_GeomType_Flag) :: geomtype = ESMF_GEOMTYPE_MESH #else logical :: cesm_coupled = .false. -type(ESMF_GeomType_Flag) :: geomtype = ESMF_GEOMTYPE_GRID +type(ESMF_GeomType_Flag) :: geomtype #endif character(len=8) :: restart_mode = 'alarms' @@ -347,6 +349,25 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(logmsg,*) use_coldstart call ESMF_LogWrite('MOM_cap:use_coldstart = '//trim(logmsg), ESMF_LOGMSG_INFO) + use_mommesh = .true. + call NUOPC_CompAttributeGet(gcomp, name="use_mommesh", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) use_mommesh=(trim(value)=="true") + write(logmsg,*) use_mommesh + call ESMF_LogWrite('MOM_cap:use_mommesh = '//trim(logmsg), ESMF_LOGMSG_INFO) + + if(use_mommesh)then + geomtype = ESMF_GEOMTYPE_MESH + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', isPresent=isPresent, isSet=isSet, rc=rc) + if (.not. isPresent .and. .not. isSet) then + call ESMF_LogWrite('geomtype set to mesh but mesh_ocn is not specified', ESMF_LOGMSG_INFO) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + else + geomtype = ESMF_GEOMTYPE_GRID + endif + end subroutine !> Called by NUOPC to advertise import and export fields. "Advertise" diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 similarity index 100% rename from config_src/nuopc_driver/mom_cap_methods.F90 rename to config_src/drivers/nuopc_cap/mom_cap_methods.F90 diff --git a/config_src/nuopc_driver/mom_cap_time.F90 b/config_src/drivers/nuopc_cap/mom_cap_time.F90 similarity index 100% rename from config_src/nuopc_driver/mom_cap_time.F90 rename to config_src/drivers/nuopc_cap/mom_cap_time.F90 diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 similarity index 98% rename from config_src/nuopc_driver/mom_ocean_model_nuopc.F90 rename to config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 493762f4bc..b8bcf8ff87 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -15,6 +15,7 @@ module MOM_ocean_model_nuopc use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : get_ocean_stocks, step_offline +use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end @@ -62,6 +63,7 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart +use iso_fortran_env, only : int64 #include @@ -1045,26 +1047,29 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -!> Write out FMS-format checsums on fields from the ocean surface state +!> Write out checksums for fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) character(len=*), intent(in) :: id !< An identifying string for this call integer, intent(in) :: timestep !< The number of elapsed timesteps type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly !! visible ocean surface fields. - integer :: n, m, outunit + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) - write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) - write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) - write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) - write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) - write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) - write(outunit,100) 'ocean%melt_potential ',mpp_chksum(ocn%melt_potential) - + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 similarity index 95% rename from config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 rename to config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 689a9f0f4a..e8673da6f8 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -3,7 +3,7 @@ module MOM_surface_forcing_nuopc ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : reproducing_sum +use MOM_coms, only : reproducing_sum, field_chksum use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT @@ -22,6 +22,7 @@ module MOM_surface_forcing_nuopc use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_io, only : stdout use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state use MOM_string_functions, only : uppercase @@ -35,10 +36,10 @@ module MOM_surface_forcing_nuopc use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn use coupler_types_mod, only : coupler_type_copy_data use data_override_mod, only : data_override_init, data_override -use fms_mod, only : stdout use mpp_mod, only : mpp_chksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init +use iso_fortran_env, only : int64 implicit none ; private @@ -497,15 +498,17 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%seaice_melt(i,j) = kg_m2_s_conversion * G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) fluxes%latent(i,j) = 0.0 + ! notice minus sign since fprec is positive into the ocean if (associated(IOB%fprec)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + & + fluxes%latent(i,j) = fluxes%latent(i,j) - & IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = - G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif + ! notice minus sign since frunoff is positive into the ocean if (associated(IOB%frunoff)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + & + fluxes%latent(i,j) = fluxes%latent(i,j) - & IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * & + fluxes%latent_frunoff_diag(i,j) = - G%mask2dT(i,j) * & IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion endif if (associated(IOB%q_flux)) then @@ -794,7 +797,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) endif forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) enddo ; enddo - + call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) elseif (wind_stagger == AGRID) then call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, stagger=AGRID, halo=1) @@ -820,7 +823,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) enddo ; enddo - + call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) else ! C-grid wind stresses. if (G%symmetric) & call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) @@ -1400,34 +1403,41 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) !! ocean in a coupled model whose checksums are reported ! local variables - integer :: n,m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(outunit,100) 'iobt%u_flux ' , mpp_chksum( iobt%u_flux ) - write(outunit,100) 'iobt%v_flux ' , mpp_chksum( iobt%v_flux ) - write(outunit,100) 'iobt%t_flux ' , mpp_chksum( iobt%t_flux ) - write(outunit,100) 'iobt%q_flux ' , mpp_chksum( iobt%q_flux ) - write(outunit,100) 'iobt%salt_flux ' , mpp_chksum( iobt%salt_flux ) - write(outunit,100) 'iobt%seaice_melt_heat' , mpp_chksum( iobt%seaice_melt_heat) - write(outunit,100) 'iobt%seaice_melt ' , mpp_chksum( iobt%seaice_melt ) - write(outunit,100) 'iobt%lw_flux ' , mpp_chksum( iobt%lw_flux ) - write(outunit,100) 'iobt%sw_flux_vis_dir' , mpp_chksum( iobt%sw_flux_vis_dir) - write(outunit,100) 'iobt%sw_flux_vis_dif' , mpp_chksum( iobt%sw_flux_vis_dif) - write(outunit,100) 'iobt%sw_flux_nir_dir' , mpp_chksum( iobt%sw_flux_nir_dir) - write(outunit,100) 'iobt%sw_flux_nir_dif' , mpp_chksum( iobt%sw_flux_nir_dif) - write(outunit,100) 'iobt%lprec ' , mpp_chksum( iobt%lprec ) - write(outunit,100) 'iobt%fprec ' , mpp_chksum( iobt%fprec ) - write(outunit,100) 'iobt%lrunoff ' , mpp_chksum( iobt%lrunoff ) - write(outunit,100) 'iobt%frunoff ' , mpp_chksum( iobt%frunoff ) - write(outunit,100) 'iobt%p ' , mpp_chksum( iobt%p ) - if (associated(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ' , mpp_chksum( iobt%ustar_berg ) - if (associated(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ' , mpp_chksum( iobt%area_berg ) - if (associated(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ' , mpp_chksum( iobt%mass_berg ) + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + outunit = stdout + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + chks = field_chksum( iobt%u_flux ) ; if (root) write(outunit,100) 'iobt%u_flux ', chks + chks = field_chksum( iobt%v_flux ) ; if (root) write(outunit,100) 'iobt%v_flux ', chks + chks = field_chksum( iobt%t_flux ) ; if (root) write(outunit,100) 'iobt%t_flux ', chks + chks = field_chksum( iobt%q_flux ) ; if (root) write(outunit,100) 'iobt%q_flux ', chks + chks = field_chksum( iobt%seaice_melt_heat); if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks + chks = field_chksum( iobt%seaice_melt) ; if (root) write(outunit,100) 'iobt%seaice_melt ', chks + chks = field_chksum( iobt%salt_flux ) ; if (root) write(outunit,100) 'iobt%salt_flux ', chks + chks = field_chksum( iobt%lw_flux ) ; if (root) write(outunit,100) 'iobt%lw_flux ', chks + chks = field_chksum( iobt%sw_flux_vis_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dir', chks + chks = field_chksum( iobt%sw_flux_vis_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dif', chks + chks = field_chksum( iobt%sw_flux_nir_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dir', chks + chks = field_chksum( iobt%sw_flux_nir_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dif', chks + chks = field_chksum( iobt%lprec ) ; if (root) write(outunit,100) 'iobt%lprec ', chks + chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks + chks = field_chksum( iobt%lrunoff ) ; if (root) write(outunit,100) 'iobt%lrunoff ', chks + chks = field_chksum( iobt%frunoff ) ; if (root) write(outunit,100) 'iobt%frunoff ', chks + chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks + if (associated(iobt%ustar_berg)) then + chks = field_chksum( iobt%ustar_berg ) ; if (root) write(outunit,100) 'iobt%ustar_berg ', chks + endif + if (associated(iobt%area_berg)) then + chks = field_chksum( iobt%area_berg ) ; if (root) write(outunit,100) 'iobt%area_berg ', chks + endif + if (associated(iobt%mass_berg)) then + chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') diff --git a/config_src/nuopc_driver/ocn_comp_NUOPC.F90 b/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90 similarity index 100% rename from config_src/nuopc_driver/ocn_comp_NUOPC.F90 rename to config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90 diff --git a/config_src/nuopc_driver/time_utils.F90 b/config_src/drivers/nuopc_cap/time_utils.F90 similarity index 100% rename from config_src/nuopc_driver/time_utils.F90 rename to config_src/drivers/nuopc_cap/time_utils.F90 diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 similarity index 100% rename from config_src/solo_driver/MESO_surface_forcing.F90 rename to config_src/drivers/solo_driver/MESO_surface_forcing.F90 diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 similarity index 99% rename from config_src/solo_driver/MOM_driver.F90 rename to config_src/drivers/solo_driver/MOM_driver.F90 index 9c222bb0bb..8edad7fa05 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -250,6 +250,10 @@ program MOM_main ! This call sets the number and affinity of threads with openMP. !$ call set_MOM_thread_affinity(ocean_nthreads, use_hyper_thread) + ! This call is required to initiate dirs%restart_input_dir for ocean_solo.res + ! The contents of dirs will be reread in initialize_MOM. + call get_MOM_input(dirs=dirs) + ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ocean_solo.res')) then call open_ASCII_file(unit, trim(dirs%restart_input_dir)//'ocean_solo.res', action=READONLY_FILE) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 similarity index 100% rename from config_src/solo_driver/MOM_surface_forcing.F90 rename to config_src/drivers/solo_driver/MOM_surface_forcing.F90 diff --git a/config_src/solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 similarity index 100% rename from config_src/solo_driver/atmos_ocean_fluxes.F90 rename to config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 similarity index 100% rename from config_src/solo_driver/user_surface_forcing.F90 rename to config_src/drivers/solo_driver/user_surface_forcing.F90 diff --git a/config_src/unit_drivers/MOM_sum_driver.F90 b/config_src/drivers/unit_drivers/MOM_sum_driver.F90 similarity index 100% rename from config_src/unit_drivers/MOM_sum_driver.F90 rename to config_src/drivers/unit_drivers/MOM_sum_driver.F90 diff --git a/src/framework/MOM_coms_infra.F90 b/config_src/infra/FMS1/MOM_coms_infra.F90 similarity index 100% rename from src/framework/MOM_coms_infra.F90 rename to config_src/infra/FMS1/MOM_coms_infra.F90 diff --git a/src/framework/MOM_constants.F90 b/config_src/infra/FMS1/MOM_constants.F90 similarity index 100% rename from src/framework/MOM_constants.F90 rename to config_src/infra/FMS1/MOM_constants.F90 diff --git a/config_src/infra/FMS1/MOM_couplertype_infra.F90 b/config_src/infra/FMS1/MOM_couplertype_infra.F90 new file mode 100644 index 0000000000..3bcccc1dc7 --- /dev/null +++ b/config_src/infra/FMS1/MOM_couplertype_infra.F90 @@ -0,0 +1,503 @@ +!> This module wraps the FMS coupler types module +module MOM_couplertype_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data, coupler_type_copy_data +use coupler_types_mod, only : coupler_type_write_chksums, coupler_type_redistribute_data +use coupler_types_mod, only : coupler_type_increment_data, coupler_type_rescale_data +use coupler_types_mod, only : coupler_type_extract_data, coupler_type_set_data +use coupler_types_mod, only : coupler_type_data_override +use coupler_types_mod, only : ind_flux, ind_alpha, ind_csurf +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type +use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux +use MOM_domain_infra, only : domain2D +use MOM_time_manager, only : time_type + +implicit none ; private + +public :: CT_spawn, CT_initialized, CT_destructor +public :: CT_set_diags, CT_send_data, CT_data_override, CT_write_chksums +public :: CT_set_data, CT_increment_data, CT_rescale_data +public :: CT_copy_data, CT_extract_data, CT_redistribute_data +public :: atmos_ocn_coupler_flux +public :: ind_flux, ind_alpha, ind_csurf +public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type + +!> This is the interface to spawn one coupler_bc_type into another. +interface CT_spawn + module procedure CT_spawn_1d_2d, CT_spawn_1d_3d, CT_spawn_2d_2d, CT_spawn_2d_3d + module procedure CT_spawn_3d_2d, CT_spawn_3d_3d +end interface CT_spawn + +!> This function interface indicates whether a coupler_bc_type has been initialized. +interface CT_initialized + module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d +end interface CT_initialized + +!> This is the interface to deallocate any data associated with a coupler_bc_type. +interface CT_destructor + module procedure CT_destructor_1d, CT_destructor_2d +end interface CT_destructor + +!> Copy all elements of the data in either a coupler_2d_bc_type or a coupler_3d_bc_type into +!! another structure of the same or the other type. Both must have the same array sizes in common +!! dimensions, while the details of any expansion from 2d to 3d are controlled by arguments. +interface CT_copy_data + module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d +end interface CT_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type with +!! the data from another. Both must have the same array sizes and rank. +interface CT_increment_data + module procedure CT_increment_data_2d, CT_increment_data_3d, CT_increment_data_2d_3d +end interface CT_increment_data + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +interface CT_rescale_data + module procedure CT_rescale_data_2d, CT_rescale_data_3d +end interface CT_rescale_data + +!> Redistribute the data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type into +!! another, which may be on different processors with a different decomposition. +interface CT_redistribute_data + module procedure CT_redistribute_data_2d, CT_redistribute_data_3d +end interface CT_redistribute_data + +!> Write out checksums for the elements of a coupler_2d_bc_type or coupler_3d_bc_type +interface CT_write_chksums + module procedure CT_write_chksums_2d, CT_write_chksums_3d +end interface CT_write_chksums + +contains + +!> This subroutine sets many of the parameters for calculating an atmosphere-ocean tracer flux +!! and retuns an integer index for that flux. +function atmos_ocn_coupler_flux(name, flux_type, implementation, param, mol_wt, & + ice_restart_file, ocean_restart_file, units, caller, verbosity) & + result (coupler_index) + + character(len=*), intent(in) :: name !< A name to use for the flux + character(len=*), intent(in) :: flux_type !< A string describing the type of this flux, + !! perhaps 'air_sea_gas_flux'. + character(len=*), intent(in) :: implementation !< A name describing the specific + !! implementation of this flux, such as 'ocmip2'. + real, dimension(:), optional, intent(in) :: param !< An array of parameters used for the fluxes + real, optional, intent(in) :: mol_wt !< The molecular weight of this tracer + character(len=*), optional, intent(in) :: ice_restart_file !< A sea-ice restart file to use with this flux. + character(len=*), optional, intent(in) :: ocean_restart_file !< An ocean restart file to use with this flux. + character(len=*), optional, intent(in) :: units !< The units of the flux + character(len=*), optional, intent(in) :: caller !< The name of the calling routine + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + integer :: coupler_index !< The resulting integer handle to use for this flux in subsequent calls. + + coupler_index = aof_set_coupler_flux(name, flux_type, implementation, & + param=param, mol_wt=mol_wt, ice_restart_file=ice_restart_file, & + ocean_restart_file=ocean_restart_file, & + units=units, caller=caller, verbosity=verbosity) + +end function atmos_ocn_coupler_flux + +!> Generate a 2-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_2d + +!> Generate a 3-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_3d + +!> Generate one 2-D coupler type using another 2-D coupler type as a template. +subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_2d + +!> Generate a 3-D coupler type using a 2-D coupler type as a template. +subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_3d + +!> Generate a 2-D coupler type using a 3-D coupler type as a template. +subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_2d + +!> Generate a 3-D coupler type using another 3-D coupler type as a template. +subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_2d + +!> Copy all elements of the data in a coupler_3d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into a coupler_3d_bc_type. +!! Both must have the same array sizes for the first two dimensions, while the extent +!! of the 3rd dimension that is being filled may be specified via optional arguments. +subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd + !! index of the 3d type to fill in. + integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd + !! index of the 3d type to fill in. + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) +end subroutine CT_copy_data_2d_3d + +!> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) + type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev) + +end subroutine CT_increment_data_2d + +!> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev, exclude_flux_type=exclude_flux_type, & + only_flux_type=only_flux_type) + +end subroutine CT_increment_data_3d + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_2d(var, scale) + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_2d + +!> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_3d(var, scale) + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_3d + +!> Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a +!! coupler_3d_bc_type +subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to + !! increment the 2d-data. There is no renormalization, + !! so if the weights do not sum to 1 in the 3rd dimension + !! there may be adverse consequences! + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + + call coupler_type_increment_data(var_in, weights, var, halo_size=halo_size) + +end subroutine CT_increment_data_2d_3d + + +!> Redistribute the data in all elements of one coupler_2d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_2d + +!> Redistribute the data in all elements of one coupler_3d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_3d + +!> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array. +subroutine CT_extract_data(var_in, bc_index, field_index, array_out, & + scale_factor, halo_size, idim, jdim) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the boundary + !! condition that is being copied, or the + !! surface flux by default. + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + call coupler_type_extract_data(var_in, bc_index, field_index, array_out, scale_factor, halo_size, idim, jdim) + +end subroutine CT_extract_data + +!> Set single 2d field in coupler_2d_bc_type from a two-dimensional array. +subroutine CT_set_data(array_in, bc_index, field_index, var, & + scale_factor, halo_size, idim, jdim) + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being set. The + !! surface concentration is set by default. + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + + integer :: subfield ! An integer indicating which field to set. + + call coupler_type_set_data(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim) + +end subroutine CT_set_data + +!> Potentially override the values in a coupler_2d_bc_type +subroutine CT_data_override(gridname, var, time) + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_data_override(gridname, var, time) +end subroutine CT_data_override + +!> Register the diagnostics of a coupler_2d_bc_type +subroutine CT_set_diags(var, diag_name, axes, time) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics + character(len=*), intent(in) :: diag_name !< name for diagnostic file, or blank not to register the fields + integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration + type(time_type), intent(in) :: time !< model time variable for registering diagnostic field + + call coupler_type_set_diags(var, diag_name, axes, time) + +end subroutine CT_set_diags + +!> Write out all diagnostics of elements of a coupler_2d_bc_type +subroutine CT_send_data(var, Time) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_send_data(var, Time) +end subroutine CT_send_data + +!> Write out checksums for the elements of a coupler_2d_bc_type +subroutine CT_write_chksums_2d(var, outunit, name_lead) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_2d + +!> Write out checksums for the elements of a coupler_3d_bc_type +subroutine CT_write_chksums_3d(var, outunit, name_lead) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_3d + +!> Indicate whether a coupler_1d_bc_type has been initialized. +logical function CT_initialized_1d(var) + type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_1d = coupler_type_initialized(var) +end function CT_initialized_1d + +!> Indicate whether a coupler_2d_bc_type has been initialized. +logical function CT_initialized_2d(var) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_2d = coupler_type_initialized(var) +end function CT_initialized_2d + +!> Indicate whether a coupler_3d_bc_type has been initialized. +logical function CT_initialized_3d(var) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_3d = coupler_type_initialized(var) +end function CT_initialized_3d + +!> Deallocate all data associated with a coupler_1d_bc_type +subroutine CT_destructor_1d(var) + type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_1d + +!> Deallocate all data associated with a coupler_2d_bc_type +subroutine CT_destructor_2d(var) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_2d + +end module MOM_couplertype_infra diff --git a/src/framework/MOM_cpu_clock_infra.F90 b/config_src/infra/FMS1/MOM_cpu_clock_infra.F90 similarity index 100% rename from src/framework/MOM_cpu_clock_infra.F90 rename to config_src/infra/FMS1/MOM_cpu_clock_infra.F90 diff --git a/src/framework/MOM_data_override_infra.F90 b/config_src/infra/FMS1/MOM_data_override_infra.F90 similarity index 100% rename from src/framework/MOM_data_override_infra.F90 rename to config_src/infra/FMS1/MOM_data_override_infra.F90 diff --git a/src/framework/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 similarity index 99% rename from src/framework/MOM_diag_manager_infra.F90 rename to config_src/infra/FMS1/MOM_diag_manager_infra.F90 index 702c464814..18c80cf24c 100644 --- a/src/framework/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -20,9 +20,9 @@ module MOM_diag_manager_infra use diag_manager_mod, only : register_diag_field_fms => register_diag_field use diag_manager_mod, only : register_static_field_fms => register_static_field use diag_manager_mod, only : get_diag_field_id_fms => get_diag_field_id -use time_manager_mod, only : time_type +use MOM_time_manager, only : time_type use MOM_domain_infra, only : MOM_domain_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_infra, only : MOM_error => MOM_err, FATAL, WARNING implicit none ; private diff --git a/src/framework/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 similarity index 97% rename from src/framework/MOM_domain_infra.F90 rename to config_src/infra/FMS1/MOM_domain_infra.F90 index 86e85e60a6..029561946b 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -4,12 +4,12 @@ module MOM_domain_infra ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms_infra, only : PE_here, root_PE, num_PEs -use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL use mpp_domains_mod, only : domain2D, domain1D use mpp_domains_mod, only : mpp_define_io_domain, mpp_define_domains, mpp_deallocate_domain -use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents +use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents, mpp_get_layout use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains @@ -42,7 +42,7 @@ module MOM_domain_infra public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass -public :: redistribute_array, broadcast_domain, global_field +public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity ! These are encoding constant parmeters. @@ -105,7 +105,7 @@ module MOM_domain_infra !> Pass an array from one MOM domain to another interface redistribute_array - module procedure redistribute_array_3d, redistribute_array_2d + module procedure redistribute_array_2d, redistribute_array_3d, redistribute_array_4d end interface redistribute_array !> Copy one MOM_domain_type into another @@ -1232,6 +1232,25 @@ subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) end subroutine redistribute_array_3d +!> Pass a 4-D array from one MOM domain to another +subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_4d + !> Rescale the values of a 4-D array in its computational domain by a constant factor subroutine rescale_comp_data_4d(domain, array, scale) @@ -1689,6 +1708,8 @@ subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & if ((MD_in%io_layout(1) + MD_in%io_layout(2) > 0) .and. & (MD_in%layout(1)*MD_in%layout(2) > 1)) then call mpp_define_io_domain(mpp_domain, MD_in%io_layout) + else + call mpp_define_io_domain(mpp_domain, (/ 1, 1 /) ) endif end subroutine clone_MD_to_d2D @@ -1921,6 +1942,29 @@ subroutine global_field(domain, local, global) call mpp_global_field(domain, local, global) end subroutine global_field +!> same_domain returns true if two domains use the same list of PEs and layouts and have the same +!! size computational domains, and false if the domains do not conform with each other. +!! Different halo sizes or indexing conventions do not alter the results. +logical function same_domain(domain_a, domain_b) + type(domain2D), intent(in) :: domain_a !< The first domain in the comparison + type(domain2D), intent(in) :: domain_b !< The second domain in the comparison + + ! Local variables + integer :: isc_a, iec_a, jsc_a, jec_a, isc_b, iec_b, jsc_b, jec_b + integer :: layout_a(2), layout_b(2) + + ! This routine currently does a few checks for consistent domains; more could be added. + call mpp_get_layout(domain_a, layout_a) + call mpp_get_layout(domain_b, layout_b) + + call get_domain_extent(domain_a, isc_a, iec_a, jsc_a, jec_a) + call get_domain_extent(domain_b, isc_b, iec_b, jsc_b, jec_b) + + same_domain = (layout_a(1) == layout_b(1)) .and. (layout_a(2) == layout_b(2)) .and. & + (iec_a - isc_a == iec_b - isc_b) .and. (jec_a - jsc_a == jec_b - jsc_b) + +end function same_domain + !> Returns arrays of the i- and j- sizes of the h-point computational domains for each !! element of the grid layout. Any input values in the extent arrays are discarded, so !! they are effectively intent out despite their declared intent of inout. diff --git a/src/framework/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 similarity index 100% rename from src/framework/MOM_ensemble_manager_infra.F90 rename to config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 diff --git a/src/framework/MOM_error_infra.F90 b/config_src/infra/FMS1/MOM_error_infra.F90 similarity index 100% rename from src/framework/MOM_error_infra.F90 rename to config_src/infra/FMS1/MOM_error_infra.F90 diff --git a/src/framework/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 similarity index 96% rename from src/framework/MOM_interp_infra.F90 rename to config_src/infra/FMS1/MOM_interp_infra.F90 index ca5b2b8516..170573f7ec 100644 --- a/src/framework/MOM_interp_infra.F90 +++ b/config_src/infra/FMS1/MOM_interp_infra.F90 @@ -4,9 +4,9 @@ module MOM_interp_infra ! This file is part of MOM6. See LICENSE.md for the license. use MOM_domain_infra, only : MOM_domain_type, domain2d -use MOM_io_infra, only : axistype use MOM_time_manager, only : time_type use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type +use mpp_io_mod, only : axistype, mpp_get_axis_data use time_interp_external_mod, only : time_interp_external use time_interp_external_mod, only : init_external_field, time_interp_external_init use time_interp_external_mod, only : get_external_field_size @@ -16,7 +16,7 @@ module MOM_interp_infra public :: horiz_interp_type, horiz_interp_init public :: time_interp_extern, init_extern_field, time_interp_external_init -public :: get_external_field_info +public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights !> Read a field based on model time, and rotate to the model domain. @@ -114,6 +114,15 @@ subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, end subroutine build_horiz_interp_weights_2d_to_2d +!> Extracts and returns the axis data stored in an axistype. +subroutine get_axis_data( axis, dat ) + type(axistype), intent(in) :: axis !< An axis type + real, dimension(:), intent(out) :: dat !< The data in the axis variable + + call mpp_get_axis_data( axis, dat ) +end subroutine get_axis_data + + !> get size of an external field from field index function get_extern_field_size(index) diff --git a/src/framework/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 similarity index 97% rename from src/framework/MOM_io_infra.F90 rename to config_src/infra/FMS1/MOM_io_infra.F90 index 3ea201235a..14e0732c8a 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -78,7 +78,7 @@ module MOM_io_infra !> Write metadata about a variable or axis to a file and store it for later reuse interface write_metadata - module procedure write_metadata_axis, write_metadata_field + module procedure write_metadata_axis, write_metadata_field, write_metadata_global end interface write_metadata !> Close a file (or fileset). If the file handle does not point to an open file, @@ -312,13 +312,12 @@ subroutine get_filename_suffix(suffix) end subroutine get_filename_suffix -!> Get information about the number of dimensions, variables, global attributes and time levels +!> Get information about the number of dimensions, variables and time levels !! in the file associated with an open file unit -subroutine get_file_info(IO_handle, ndim, nvar, natt, ntime) +subroutine get_file_info(IO_handle, ndim, nvar, ntime) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O integer, optional, intent(out) :: ndim !< The number of dimensions in the file integer, optional, intent(out) :: nvar !< The number of variables in the file - integer, optional, intent(out) :: natt !< The number of global attributes in the file integer, optional, intent(out) :: ntime !< The number of time levels in the file ! Local variables @@ -328,7 +327,6 @@ subroutine get_file_info(IO_handle, ndim, nvar, natt, ntime) if (present(ndim)) ndim = ndims if (present(nvar)) nvar = nvars - if (present(natt)) natt = natts if (present(ntime)) ntime = ntimes end subroutine get_file_info @@ -683,7 +681,7 @@ subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:,:), intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value @@ -697,7 +695,7 @@ subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:), intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value @@ -711,7 +709,7 @@ subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:), intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value @@ -724,7 +722,7 @@ subroutine write_field_1d(IO_handle, field_md, field, tstamp) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, dimension(:), intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) end subroutine write_field_1d @@ -734,7 +732,7 @@ subroutine write_field_0d(IO_handle, field_md, field, tstamp) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) end subroutine write_field_0d @@ -750,7 +748,8 @@ end subroutine MOM_write_axis !> Store information about an axis in a previously defined axistype and write this !! information to the file indicated by unit. -subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, data, calendar) +subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, & + data, edge_axis, calendar) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(axistype), intent(inout) :: axis !< The axistype where this information is stored. character(len=*), intent(in) :: name !< The name in the file of this axis @@ -763,6 +762,7 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian !! -1 if they increase downward. type(domain1D), optional, intent(in) :: domain !< The domain decomposion for this axis real, dimension(:), optional, intent(in) :: data !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis !< If true, this axis marks an edge of the tracer cells character(len=*), optional, intent(in) :: calendar !< The name of the calendar used with a time axis call mpp_write_meta(IO_handle%unit, axis, name, units, longname, cartesian=cartesian, sense=sense, & @@ -772,19 +772,13 @@ end subroutine write_metadata_axis !> Store information about an output variable in a previously defined fieldtype and write this !! information to the file indicated by unit. subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & - min, max, fill, scale, add, pack, standard_name, checksum) + pack, standard_name, checksum) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(inout) :: field !< The fieldtype where this information is stored type(axistype), dimension(:), intent(in) :: axes !< Handles for the axis used for this variable character(len=*), intent(in) :: name !< The name in the file of this variable character(len=*), intent(in) :: units !< The units of this variable character(len=*), intent(in) :: longname !< The long description of this variable - real, optional, intent(in) :: min !< The minimum valid value for this variable - real, optional, intent(in) :: max !< The maximum valid value for this variable - real, optional, intent(in) :: fill !< Missing data fill value - real, optional, intent(in) :: scale !< An multiplicative factor by which to scale - !! the variable before output - real, optional, intent(in) :: add !< An offset to add to the variable before output integer, optional, intent(in) :: pack !< A precision reduction factor with which the !! variable. The default, 1, has no reduction, !! but 2 is not uncommon. @@ -793,9 +787,19 @@ subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & optional, intent(in) :: checksum !< Checksum values that can be used to verify reads. - call mpp_write_meta(IO_handle%unit, field, axes, name, units, longname, min=min, max=max, & - fill=fill, scale=scale, add=add, pack=pack, standard_name=standard_name, checksum=checksum) + call mpp_write_meta(IO_handle%unit, field, axes, name, units, longname, & + pack=pack, standard_name=standard_name, checksum=checksum) + ! unused opt. args: min=min, max=max, fill=fill, scale=scale, add=add, & end subroutine write_metadata_field +!> Write a global text attribute to a file. +subroutine write_metadata_global(IO_handle, name, attribute) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + character(len=*), intent(in) :: name !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute !< The value of this attribute + + call mpp_write_meta(IO_handle%unit, name, cval=attribute) +end subroutine write_metadata_global + end module MOM_io_infra diff --git a/src/framework/MOM_time_manager.F90 b/config_src/infra/FMS1/MOM_time_manager.F90 similarity index 100% rename from src/framework/MOM_time_manager.F90 rename to config_src/infra/FMS1/MOM_time_manager.F90 diff --git a/config_src/infra/FMS2/MOM_coms_infra.F90 b/config_src/infra/FMS2/MOM_coms_infra.F90 new file mode 100644 index 0000000000..555b4df119 --- /dev/null +++ b/config_src/infra/FMS2/MOM_coms_infra.F90 @@ -0,0 +1,455 @@ +!> Thin interfaces to non-domain-oriented mpp communication subroutines +module MOM_coms_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use iso_fortran_env, only : int32, int64 + +use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes, mpp_set_root_pe +use mpp_mod, only : mpp_set_current_pelist, mpp_get_current_pelist +use mpp_mod, only : mpp_broadcast, mpp_sync, mpp_sync_self, mpp_chksum +use mpp_mod, only : mpp_sum, mpp_max, mpp_min +use memutils_mod, only : print_memuse_stats +use fms_mod, only : fms_end, fms_init + +implicit none ; private + +public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist +public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: field_chksum, MOM_infra_init, MOM_infra_end + +! This module provides interfaces to the non-domain-oriented communication +! subroutines. + +!> Communicate an array, string or scalar from one PE to others +interface broadcast + module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D +end interface broadcast + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +interface field_chksum + module procedure field_chksum_real_0d + module procedure field_chksum_real_1d + module procedure field_chksum_real_2d + module procedure field_chksum_real_3d + module procedure field_chksum_real_4d +end interface field_chksum + +!> Find the sum of field across PEs, and update PEs with the sums. +interface sum_across_PEs + module procedure sum_across_PEs_int4_0d + module procedure sum_across_PEs_int4_1d + module procedure sum_across_PEs_int8_0d + module procedure sum_across_PEs_int8_1d + module procedure sum_across_PEs_int8_2d + module procedure sum_across_PEs_real_0d + module procedure sum_across_PEs_real_1d + module procedure sum_across_PEs_real_2d +end interface sum_across_PEs + +!> Find the maximum value of field across PEs, and update PEs with the values. +interface max_across_PEs + module procedure max_across_PEs_int_0d + module procedure max_across_PEs_real_0d + module procedure max_across_PEs_real_1d +end interface max_across_PEs + +!> Find the minimum value of field across PEs, and update PEs with the values. +interface min_across_PEs + module procedure min_across_PEs_int_0d + module procedure min_across_PEs_real_0d + module procedure min_across_PEs_real_1d +end interface min_across_PEs + +contains + +!> Return the ID of the PE for the current process. +function PE_here() result(pe) + integer :: pe !< PE ID of the current process + pe = mpp_pe() +end function PE_here + +!> Return the ID of the root PE for the PE list of the current procss. +function root_PE() result(pe) + integer :: pe !< root PE ID + pe = mpp_root_pe() +end function root_PE + +!> Return the number of PEs for the current PE list. +function num_PEs() result(npes) + integer :: npes !< Number of PEs + npes = mpp_npes() +end function num_PEs + +!> Designate a PE as the root PE +subroutine set_rootPE(pe) + integer, intent(in) :: pe !< ID of the PE to be assigned as root + call mpp_set_root_pe(pe) +end subroutine + +!> Set the current PE list. If no list is provided, then the current PE list +!! is set to the list of all available PEs on the communicator. Setting the +!! list will trigger a rank synchronization unless the `no_sync` flag is set. +subroutine Set_PEList(pelist, no_sync) + integer, optional, intent(in) :: pelist(:) !< List of PEs to set for communication + logical, optional, intent(in) :: no_sync !< Do not sync after list update. + call mpp_set_current_pelist(pelist, no_sync) +end subroutine Set_PEList + +!> Retrieve the current PE list and any metadata if requested. +subroutine Get_PEList(pelist, name, commID) + integer, intent(out) :: pelist(:) !< List of PE IDs of the current PE list + character(len=*), optional, intent(out) :: name !< Name of PE list + integer, optional, intent(out) :: commID !< Communicator ID of PE list + + call mpp_get_current_pelist(pelist, name, commiD) +end subroutine Get_PEList + +!> Communicate a 1-D array of character strings from one PE to others +subroutine broadcast_char(dat, length, from_PE, PElist, blocking) + character(len=*), intent(inout) :: dat(:) !< The data to communicate and destination + integer, intent(in) :: length !< The length of each string + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_char + +!> Communicate an integer from one PE to others +subroutine broadcast_int64_0D(dat, from_PE, PElist, blocking) + integer(kind=int64), intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int64_0D + + +!> Communicate an integer from one PE to others +subroutine broadcast_int32_0D(dat, from_PE, PElist, blocking) + integer(kind=int32), intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int32_0D + +!> Communicate a 1-D array of integers from one PE to others +subroutine broadcast_int1D(dat, length, from_PE, PElist, blocking) + integer, dimension(:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int1D + +!> Communicate a real number from one PE to others +subroutine broadcast_real0D(dat, from_PE, PElist, blocking) + real, intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real0D + +!> Communicate a 1-D array of reals from one PE to others +subroutine broadcast_real1D(dat, length, from_PE, PElist, blocking) + real, dimension(:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real1D + +!> Communicate a 2-D array of reals from one PE to others +subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real2D + +! field_chksum wrappers + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_0d(field, pelist, mask_val) result(chksum) + real, intent(in) :: field !< Input scalar + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_0d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_1d(field, pelist, mask_val) result(chksum) + real, dimension(:), intent(in) :: field !< Input array + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_1d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_2d(field, pelist, mask_val) result(chksum) + real, dimension(:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_2d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_3d(field, pelist, mask_val) result(chksum) + real, dimension(:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_3d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_4d(field, pelist, mask_val) result(chksum) + real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_4d + +! sum_across_PEs wrappers + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_int4_0d(field, pelist) + integer(kind=int32), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_int4_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int4_1d(field, length, pelist) + integer(kind=int32), dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int4_1d + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_int8_0d(field, pelist) + integer(kind=int64), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_int8_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int8_1d(field, length, pelist) + integer(kind=int64), dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int8_1d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int8_2d(field, length, pelist) + integer(kind=int64), & + dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< The total number of positions to sum, usually + !! the product of the array sizes. + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int8_2d + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_real_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_real_1d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_real_2d(field, length, pelist) + real, dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< The total number of positions to sum, usually + !! the product of the array sizes. + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_real_2d + +! max_across_PEs wrappers + +!> Find the maximum value of field across PEs, and store this maximum in field. +subroutine max_across_PEs_int_0d(field, pelist) + integer, intent(inout) :: field !< The values to compare, the maximum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, pelist) +end subroutine max_across_PEs_int_0d + +!> Find the maximum value of field across PEs, and store this maximum in field. +subroutine max_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< The values to compare, the maximum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, pelist) +end subroutine max_across_PEs_real_0d + +!> Find the maximum values in each position of field across PEs, and store these minima in field. +subroutine max_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The list of values being compared, with the + !! maxima in each position upon return + integer, intent(in) :: length !< Number of elements in field to compare + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, length, pelist) +end subroutine max_across_PEs_real_1d + +! min_across_PEs wrappers + +!> Find the minimum value of field across PEs, and store this minimum in field. +subroutine min_across_PEs_int_0d(field, pelist) + integer, intent(inout) :: field !< The values to compare, the minimum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_min(field, pelist) +end subroutine min_across_PEs_int_0d + +!> Find the minimum value of field across PEs, and store this minimum in field. +subroutine min_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< The values to compare, the minimum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + call mpp_min(field, pelist) +end subroutine min_across_PEs_real_0d + +!> Find the minimum values in each position of field across PEs, and store these minima in field. +subroutine min_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The list of values being compared, with the + !! minima in each position upon return + integer, intent(in) :: length !< Number of elements in field to compare + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_min(field, length, pelist) +end subroutine min_across_PEs_real_1d + +!> Initialize the model framework, including PE communication over a designated communicator. +!! If no communicator ID is provided, the framework's default communicator is used. +subroutine MOM_infra_init(localcomm) + integer, optional, intent(in) :: localcomm !< Communicator ID to initialize + call fms_init(localcomm) +end subroutine + +!> This subroutine carries out all of the calls required to close out the infrastructure cleanly. +!! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. +subroutine MOM_infra_end + call print_memuse_stats( 'Memory HiWaterMark', always=.TRUE. ) + call fms_end() +end subroutine MOM_infra_end + +end module MOM_coms_infra diff --git a/config_src/infra/FMS2/MOM_constants.F90 b/config_src/infra/FMS2/MOM_constants.F90 new file mode 100644 index 0000000000..2db177e08c --- /dev/null +++ b/config_src/infra/FMS2/MOM_constants.F90 @@ -0,0 +1,14 @@ +!> Provides a few physical constants +module MOM_constants + +! This file is part of MOM6. See LICENSE.md for the license. + +use constants_mod, only : HLV, HLF + +implicit none ; private + +!> The constant offset for converting temperatures in Kelvin to Celsius +real, public, parameter :: CELSIUS_KELVIN_OFFSET = 273.15 +public :: HLV, HLF + +end module MOM_constants diff --git a/config_src/infra/FMS2/MOM_couplertype_infra.F90 b/config_src/infra/FMS2/MOM_couplertype_infra.F90 new file mode 100644 index 0000000000..3bcccc1dc7 --- /dev/null +++ b/config_src/infra/FMS2/MOM_couplertype_infra.F90 @@ -0,0 +1,503 @@ +!> This module wraps the FMS coupler types module +module MOM_couplertype_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data, coupler_type_copy_data +use coupler_types_mod, only : coupler_type_write_chksums, coupler_type_redistribute_data +use coupler_types_mod, only : coupler_type_increment_data, coupler_type_rescale_data +use coupler_types_mod, only : coupler_type_extract_data, coupler_type_set_data +use coupler_types_mod, only : coupler_type_data_override +use coupler_types_mod, only : ind_flux, ind_alpha, ind_csurf +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type +use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux +use MOM_domain_infra, only : domain2D +use MOM_time_manager, only : time_type + +implicit none ; private + +public :: CT_spawn, CT_initialized, CT_destructor +public :: CT_set_diags, CT_send_data, CT_data_override, CT_write_chksums +public :: CT_set_data, CT_increment_data, CT_rescale_data +public :: CT_copy_data, CT_extract_data, CT_redistribute_data +public :: atmos_ocn_coupler_flux +public :: ind_flux, ind_alpha, ind_csurf +public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type + +!> This is the interface to spawn one coupler_bc_type into another. +interface CT_spawn + module procedure CT_spawn_1d_2d, CT_spawn_1d_3d, CT_spawn_2d_2d, CT_spawn_2d_3d + module procedure CT_spawn_3d_2d, CT_spawn_3d_3d +end interface CT_spawn + +!> This function interface indicates whether a coupler_bc_type has been initialized. +interface CT_initialized + module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d +end interface CT_initialized + +!> This is the interface to deallocate any data associated with a coupler_bc_type. +interface CT_destructor + module procedure CT_destructor_1d, CT_destructor_2d +end interface CT_destructor + +!> Copy all elements of the data in either a coupler_2d_bc_type or a coupler_3d_bc_type into +!! another structure of the same or the other type. Both must have the same array sizes in common +!! dimensions, while the details of any expansion from 2d to 3d are controlled by arguments. +interface CT_copy_data + module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d +end interface CT_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type with +!! the data from another. Both must have the same array sizes and rank. +interface CT_increment_data + module procedure CT_increment_data_2d, CT_increment_data_3d, CT_increment_data_2d_3d +end interface CT_increment_data + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +interface CT_rescale_data + module procedure CT_rescale_data_2d, CT_rescale_data_3d +end interface CT_rescale_data + +!> Redistribute the data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type into +!! another, which may be on different processors with a different decomposition. +interface CT_redistribute_data + module procedure CT_redistribute_data_2d, CT_redistribute_data_3d +end interface CT_redistribute_data + +!> Write out checksums for the elements of a coupler_2d_bc_type or coupler_3d_bc_type +interface CT_write_chksums + module procedure CT_write_chksums_2d, CT_write_chksums_3d +end interface CT_write_chksums + +contains + +!> This subroutine sets many of the parameters for calculating an atmosphere-ocean tracer flux +!! and retuns an integer index for that flux. +function atmos_ocn_coupler_flux(name, flux_type, implementation, param, mol_wt, & + ice_restart_file, ocean_restart_file, units, caller, verbosity) & + result (coupler_index) + + character(len=*), intent(in) :: name !< A name to use for the flux + character(len=*), intent(in) :: flux_type !< A string describing the type of this flux, + !! perhaps 'air_sea_gas_flux'. + character(len=*), intent(in) :: implementation !< A name describing the specific + !! implementation of this flux, such as 'ocmip2'. + real, dimension(:), optional, intent(in) :: param !< An array of parameters used for the fluxes + real, optional, intent(in) :: mol_wt !< The molecular weight of this tracer + character(len=*), optional, intent(in) :: ice_restart_file !< A sea-ice restart file to use with this flux. + character(len=*), optional, intent(in) :: ocean_restart_file !< An ocean restart file to use with this flux. + character(len=*), optional, intent(in) :: units !< The units of the flux + character(len=*), optional, intent(in) :: caller !< The name of the calling routine + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + integer :: coupler_index !< The resulting integer handle to use for this flux in subsequent calls. + + coupler_index = aof_set_coupler_flux(name, flux_type, implementation, & + param=param, mol_wt=mol_wt, ice_restart_file=ice_restart_file, & + ocean_restart_file=ocean_restart_file, & + units=units, caller=caller, verbosity=verbosity) + +end function atmos_ocn_coupler_flux + +!> Generate a 2-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_2d + +!> Generate a 3-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_3d + +!> Generate one 2-D coupler type using another 2-D coupler type as a template. +subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_2d + +!> Generate a 3-D coupler type using a 2-D coupler type as a template. +subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_3d + +!> Generate a 2-D coupler type using a 3-D coupler type as a template. +subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_2d + +!> Generate a 3-D coupler type using another 3-D coupler type as a template. +subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_2d + +!> Copy all elements of the data in a coupler_3d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into a coupler_3d_bc_type. +!! Both must have the same array sizes for the first two dimensions, while the extent +!! of the 3rd dimension that is being filled may be specified via optional arguments. +subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd + !! index of the 3d type to fill in. + integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd + !! index of the 3d type to fill in. + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) +end subroutine CT_copy_data_2d_3d + +!> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) + type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev) + +end subroutine CT_increment_data_2d + +!> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev, exclude_flux_type=exclude_flux_type, & + only_flux_type=only_flux_type) + +end subroutine CT_increment_data_3d + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_2d(var, scale) + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_2d + +!> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_3d(var, scale) + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_3d + +!> Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a +!! coupler_3d_bc_type +subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to + !! increment the 2d-data. There is no renormalization, + !! so if the weights do not sum to 1 in the 3rd dimension + !! there may be adverse consequences! + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + + call coupler_type_increment_data(var_in, weights, var, halo_size=halo_size) + +end subroutine CT_increment_data_2d_3d + + +!> Redistribute the data in all elements of one coupler_2d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_2d + +!> Redistribute the data in all elements of one coupler_3d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_3d + +!> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array. +subroutine CT_extract_data(var_in, bc_index, field_index, array_out, & + scale_factor, halo_size, idim, jdim) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the boundary + !! condition that is being copied, or the + !! surface flux by default. + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + call coupler_type_extract_data(var_in, bc_index, field_index, array_out, scale_factor, halo_size, idim, jdim) + +end subroutine CT_extract_data + +!> Set single 2d field in coupler_2d_bc_type from a two-dimensional array. +subroutine CT_set_data(array_in, bc_index, field_index, var, & + scale_factor, halo_size, idim, jdim) + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being set. The + !! surface concentration is set by default. + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + + integer :: subfield ! An integer indicating which field to set. + + call coupler_type_set_data(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim) + +end subroutine CT_set_data + +!> Potentially override the values in a coupler_2d_bc_type +subroutine CT_data_override(gridname, var, time) + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_data_override(gridname, var, time) +end subroutine CT_data_override + +!> Register the diagnostics of a coupler_2d_bc_type +subroutine CT_set_diags(var, diag_name, axes, time) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics + character(len=*), intent(in) :: diag_name !< name for diagnostic file, or blank not to register the fields + integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration + type(time_type), intent(in) :: time !< model time variable for registering diagnostic field + + call coupler_type_set_diags(var, diag_name, axes, time) + +end subroutine CT_set_diags + +!> Write out all diagnostics of elements of a coupler_2d_bc_type +subroutine CT_send_data(var, Time) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_send_data(var, Time) +end subroutine CT_send_data + +!> Write out checksums for the elements of a coupler_2d_bc_type +subroutine CT_write_chksums_2d(var, outunit, name_lead) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_2d + +!> Write out checksums for the elements of a coupler_3d_bc_type +subroutine CT_write_chksums_3d(var, outunit, name_lead) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_3d + +!> Indicate whether a coupler_1d_bc_type has been initialized. +logical function CT_initialized_1d(var) + type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_1d = coupler_type_initialized(var) +end function CT_initialized_1d + +!> Indicate whether a coupler_2d_bc_type has been initialized. +logical function CT_initialized_2d(var) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_2d = coupler_type_initialized(var) +end function CT_initialized_2d + +!> Indicate whether a coupler_3d_bc_type has been initialized. +logical function CT_initialized_3d(var) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_3d = coupler_type_initialized(var) +end function CT_initialized_3d + +!> Deallocate all data associated with a coupler_1d_bc_type +subroutine CT_destructor_1d(var) + type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_1d + +!> Deallocate all data associated with a coupler_2d_bc_type +subroutine CT_destructor_2d(var) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_2d + +end module MOM_couplertype_infra diff --git a/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 b/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 new file mode 100644 index 0000000000..47d7bbedaa --- /dev/null +++ b/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 @@ -0,0 +1,93 @@ +!> Wraps the MPP cpu clock functions +!! +!! The functions and constants should be accessed via mom_cpu_clock +module MOM_cpu_clock_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module +use fms_mod, only : clock_flag_default +use mpp_mod, only : mpp_clock_begin +use mpp_mod, only : mpp_clock_end, mpp_clock_id +use mpp_mod, only : MPP_CLOCK_COMPONENT => CLOCK_COMPONENT +use mpp_mod, only : MPP_CLOCK_SUBCOMPONENT => CLOCK_SUBCOMPONENT +use mpp_mod, only : MPP_CLOCK_MODULE_DRIVER => CLOCK_MODULE_DRIVER +use mpp_mod, only : MPP_CLOCK_MODULE => CLOCK_MODULE +use mpp_mod, only : MPP_CLOCK_ROUTINE => CLOCK_ROUTINE +use mpp_mod, only : MPP_CLOCK_LOOP => CLOCK_LOOP +use mpp_mod, only : MPP_CLOCK_INFRA => CLOCK_INFRA + +implicit none ; private + +! Public entities +public :: cpu_clock_id, cpu_clock_begin, cpu_clock_end +public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE +public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! component, e.g. the entire MOM6 model +integer, parameter :: CLOCK_COMPONENT = MPP_CLOCK_COMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! sub-component, e.g. dynamics or thermodynamics +integer, parameter :: CLOCK_SUBCOMPONENT = MPP_CLOCK_SUBCOMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module driver, e.g. a routine that calls multiple other routines +integer, parameter :: CLOCK_MODULE_DRIVER = MPP_CLOCK_MODULE_DRIVER + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module, e.g. the main entry routine for a module +integer, parameter :: CLOCK_MODULE = MPP_CLOCK_MODULE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! subroutine or function +integer, parameter :: CLOCK_ROUTINE = MPP_CLOCK_ROUTINE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! section with in a routine, e.g. around a loop +integer, parameter :: CLOCK_LOOP = MPP_CLOCK_LOOP + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for an +!! infrastructure operation, e.g. a halo update +integer, parameter :: CLOCK_INFRA = MPP_CLOCK_INFRA + +contains + +!> Turns on clock with handle "id" +subroutine cpu_clock_begin(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_begin(id) + +end subroutine cpu_clock_begin + +!> Turns off clock with handle "id" +subroutine cpu_clock_end(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_end(id) + +end subroutine cpu_clock_end + +!> Returns the integer handle for a named CPU clock. +integer function cpu_clock_id( name, synchro_flag, grain ) + character(len=*), intent(in) :: name !< The unique name of the CPU clock + integer, optional, intent(in) :: synchro_flag !< An integer flag that controls whether the PEs + !! are synchronized before the cpu clocks start counting. + !! Synchronization occurs before the start of a clock if this + !! is odd, while additional (expensive) statistics can set + !! for other values. If absent, the default is taken from the + !! settings for FMS. + integer, optional, intent(in) :: grain !< The timing granularity for this clock, usually set to + !! the values of CLOCK_COMPONENT, CLOCK_ROUTINE, CLOCK_LOOP, etc. + + if (present(synchro_flag)) then + cpu_clock_id = mpp_clock_id(name, flags=synchro_flag, grain=grain) + else + cpu_clock_id = mpp_clock_id(name, flags=clock_flag_default, grain=grain) + endif + +end function cpu_clock_id + +end module MOM_cpu_clock_infra diff --git a/config_src/infra/FMS2/MOM_data_override_infra.F90 b/config_src/infra/FMS2/MOM_data_override_infra.F90 new file mode 100644 index 0000000000..1484f0c128 --- /dev/null +++ b/config_src/infra/FMS2/MOM_data_override_infra.F90 @@ -0,0 +1,105 @@ +!> These interfaces allow for ocean or sea-ice variables to be replaced with data. +module MOM_data_override_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_time_manager, only : time_type +use data_override_mod, only : data_override_init +use data_override_mod, only : data_override +use data_override_mod, only : data_override_unset_domains + +implicit none ; private + +public :: impose_data_init, impose_data, impose_data_unset_domains + +!> Potentially override the values of a field in the model with values from a dataset. +interface impose_data + module procedure data_override_MD, data_override_2d +end interface + +contains + +!> Initialize the data override capability and set the domains for the ocean and ice components. +!> There should be a call to impose_data_init before impose_data is called. +subroutine impose_data_init(MOM_domain_in, Ocean_domain_in, Ice_domain_in) + type (MOM_domain_type), intent(in), optional :: MOM_domain_in + type (domain2d), intent(in), optional :: Ocean_domain_in + type (domain2d), intent(in), optional :: Ice_domain_in + + if (present(MOM_domain_in)) then + call data_override_init(Ocean_domain_in=MOM_domain_in%mpp_domain, Ice_domain_in=Ice_domain_in) + else + call data_override_init(Ocean_domain_in=Ocean_domain_in, Ice_domain_in=Ice_domain_in) + endif +end subroutine impose_data_init + + +!> Potentially override a 2-d field on a MOM6 domain with values from a dataset. +subroutine data_override_MD(domain, fieldname, data_2D, time, scale, override, is_ice) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + character(len=*), intent(in) :: fieldname !< Name of the field to override + real, dimension(:,:), intent(inout) :: data_2D !< Data that may be modified by this call. + type(time_type), intent(in) :: time !< The model time, and the time for the data + real, optional, intent(in) :: scale !< A scaling factor that an overridden field is + !! multiplied by before it is returned. However, + !! if there is no override, there is no rescaling. + logical, optional, intent(out) :: override !< True if the field has been overridden successfully + logical, optional, intent(in) :: is_ice !< If present and true, use the ice domain. + + logical :: overridden, is_ocean + integer :: i, j, is, ie, js, je + + overridden = .false. + is_ocean = .true. ; if (present(is_ice)) is_ocean = .not.is_ice + if (is_ocean) then + call data_override('OCN', fieldname, data_2D, time, override=overridden) + else + call data_override('ICE', fieldname, data_2D, time, override=overridden) + endif + + if (overridden .and. present(scale)) then ; if (scale /= 1.0) then + ! Rescale data in the computational domain if the data override has occurred. + call get_simple_array_i_ind(domain, size(data_2D,1), is, ie) + call get_simple_array_j_ind(domain, size(data_2D,2), js, je) + do j=js,je ; do i=is,ie + data_2D(i,j) = scale*data_2D(i,j) + enddo ; enddo + endif ; endif + + if (present(override)) override = overridden + +end subroutine data_override_MD + + +!> Potentially override a 2-d field with values from a dataset. +subroutine data_override_2d(gridname, fieldname, data_2D, time, override) + character(len=3), intent(in) :: gridname !< String identifying the model component, in MOM6 + !! and SIS this may be either 'OCN' or 'ICE' + character(len=*), intent(in) :: fieldname !< Name of the field to override + real, dimension(:,:), intent(inout) :: data_2D !< Data that may be modified by this call + type(time_type), intent(in) :: time !< The model time, and the time for the data + logical, optional, intent(out) :: override !< True if the field has been overridden successfully + + call data_override(gridname, fieldname, data_2D, time, override) + +end subroutine data_override_2d + +!> Unset domains that had previously been set for use by data_override. +subroutine impose_data_unset_domains(unset_Ocean, unset_Ice, must_be_set) + logical, intent(in), optional :: unset_Ocean !< If present and true, unset the ocean domain for overrides + logical, intent(in), optional :: unset_Ice !< If present and true, unset the sea-ice domain for overrides + logical, intent(in), optional :: must_be_set !< If present and true, it is a fatal error to unset + !! a domain that is not set. + + call data_override_unset_domains(unset_Ocean=unset_Ocean, unset_Ice=unset_Ice, & + must_be_set=must_be_set) +end subroutine impose_data_unset_domains + +end module MOM_data_override_infra + +!> \namespace MOM_data_override_infra +!! +!! The routines here wrap routines from the FMS module data_override_mod, which potentially replace +!! model values with values read from a data file. diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 new file mode 100644 index 0000000000..18c80cf24c --- /dev/null +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -0,0 +1,423 @@ +!> A wrapper for the FMS diag_manager routines. This module should be the +!! only MOM6 module which imports the FMS shared infrastructure for +!! diagnostics. Pass through interfaces are being documented +!! here and renamed in order to clearly identify these APIs as being +!! consistent with the FMS infrastructure (Any future updates to +!! those APIs would be applied here). +module MOM_diag_manager_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use diag_axis_mod, only : fms_axis_init=>diag_axis_init +use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name +use diag_axis_mod, only : EAST, NORTH +use diag_data_mod, only : null_axis_id +use diag_manager_mod, only : fms_diag_manager_init => diag_manager_init +use diag_manager_mod, only : fms_diag_manager_end => diag_manager_end +use diag_manager_mod, only : send_data_fms => send_data +use diag_manager_mod, only : fms_diag_field_add_attribute => diag_field_add_attribute +use diag_manager_mod, only : DIAG_FIELD_NOT_FOUND +use diag_manager_mod, only : register_diag_field_fms => register_diag_field +use diag_manager_mod, only : register_static_field_fms => register_static_field +use diag_manager_mod, only : get_diag_field_id_fms => get_diag_field_id +use MOM_time_manager, only : time_type +use MOM_domain_infra, only : MOM_domain_type +use MOM_error_infra, only : MOM_error => MOM_err, FATAL, WARNING + +implicit none ; private + +!> transmit data for diagnostic output +interface register_diag_field_infra + module procedure register_diag_field_infra_scalar + module procedure register_diag_field_infra_array +end interface register_diag_field_infra + +!> transmit data for diagnostic output +interface send_data_infra + module procedure send_data_infra_0d, send_data_infra_1d + module procedure send_data_infra_2d, send_data_infra_3d +#ifdef OVERLOAD_R8 + module procedure send_data_infra_2d_r8, send_data_infra_3d_r8 +#endif +end interface send_data_infra + +!> Add an attribute to a diagnostic field +interface MOM_diag_field_add_attribute + module procedure MOM_diag_field_add_attribute_scalar_r + module procedure MOM_diag_field_add_attribute_scalar_i + module procedure MOM_diag_field_add_attribute_scalar_c + module procedure MOM_diag_field_add_attribute_r1d + module procedure MOM_diag_field_add_attribute_i1d +end interface MOM_diag_field_add_attribute + + +! Public interfaces +public MOM_diag_axis_init +public get_MOM_diag_axis_name +public MOM_diag_manager_init +public MOM_diag_manager_end +public send_data_infra +public MOM_diag_field_add_attribute +public register_diag_field_infra +public register_static_field_infra +public get_MOM_diag_field_id +! Public data +public null_axis_id +public DIAG_FIELD_NOT_FOUND +public EAST, NORTH + + +contains + +!> Initialize a diagnostic axis +integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & + & direction, edges, set_name, coarsen, null_axis) + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif + + if (present(MOM_domain)) then + coarsening = 1 ; if (present(coarsen)) coarsening = coarsen + if (coarsening == 1) then + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges, & + domain2=MOM_domain%mpp_domain, domain_position=position) + elseif (coarsening == 2) then + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges, & + domain2=MOM_domain%mpp_domain_d2, domain_position=position) + else + call MOM_error(FATAL, "diag_axis_init called with an invalid value of coarsen.") + endif + else + if (present(coarsen)) then ; if (coarsen /= 1) then + call MOM_error(FATAL, "diag_axis_init does not support grid coarsening without a MOM_domain.") + endif ; endif + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges) + endif + +end function MOM_diag_axis_init + +!> Returns the short name of the axis +subroutine get_MOM_diag_axis_name(id, name) + integer, intent(in) :: id !< The axis numeric id + character(len=*), intent(out) :: name !< The short name of the axis + + call fms_get_diag_axis_name(id, name) + +end subroutine get_MOM_diag_axis_name + +!> Return a unique numeric ID field a module/field name combination. +integer function get_MOM_diag_field_id(module_name, field_name) + character(len=*), intent(in) :: module_name !< A module name string to query. + character(len=*), intent(in) :: field_name !< A field name string to query. + + + get_MOM_diag_field_id = -1 + get_MOM_diag_field_id = get_diag_field_id_fms(module_name, field_name) + +end function get_MOM_diag_field_id + +!> Initializes the diagnostic manager +subroutine MOM_diag_manager_init(diag_model_subset, time_init, err_msg) + integer, optional, intent(in) :: diag_model_subset !< An optional diagnostic subset + integer, dimension(6), optional, intent(in) :: time_init !< An optional reference time for diagnostics + !! The default uses the value contained in the + !! diag_table. Format is Y-M-D-H-M-S + character(len=*), optional, intent(out) :: err_msg !< Error message. + call FMS_diag_manager_init(diag_model_subset, time_init, err_msg) + +end subroutine MOM_diag_manager_init + +!> Close the diagnostic manager +subroutine MOM_diag_manager_end(time) + type(time_type), intent(in) :: time !< Model time at call to close. + + call FMS_diag_manager_end(time) + +end subroutine MOM_diag_manager_end + +!> Register a MOM diagnostic field for scalars +integer function register_diag_field_infra_scalar(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, & + err_msg, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + type(time_type), optional, intent(in) :: init_time !< The registration time + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Field units + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(out):: err_msg !< An error message to return + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_diag_field_infra_scalar = register_diag_field_fms(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume) + +end function register_diag_field_infra_scalar + +!> Register a MOM diagnostic field for scalars +integer function register_diag_field_infra_array(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, verbose, & + do_not_log, err_msg, interp_method, tile_count, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, dimension(:), intent(in) :: axes !< Diagnostic IDs of axis attributes for the field + type(time_type), optional, intent(in) :: init_time !< The registration time + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Units of the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: verbose !< If true, provide additional log information + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< The tile number for the current PE + character(len=*), optional, intent(out):: err_msg !< An error message to return + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_diag_field_infra_array = register_diag_field_fms(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, & + err_msg, interp_method, tile_count, area, volume) + +end function register_diag_field_infra_array + + +integer function register_static_field_infra(module_name, field_name, axes, long_name, units, & + missing_value, range, mask_variant, standard_name, do_not_log, interp_method, & + tile_count, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, dimension(:), intent(in) :: axes !< Diagnostic IDs of axis attributes for the field + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Units of the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< The tile number for the current PE + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & missing_value, range, mask_variant, standard_name, dynamic=.false.,do_not_log=do_not_log, & + interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) +end function register_static_field_infra + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_0d(diag_field_id, field, time, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, intent(in) :: field !< The value being recorded + TYPE(time_type), optional, intent(in) :: time !< The time for the current record + CHARACTER(len=*), optional, intent(out) :: err_msg !< An optional error message + + send_data_infra_0d = send_data_fms(diag_field_id, field, time, err_msg) +end function send_data_infra_0d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_1d(diag_field_id, field, is_in, ie_in, time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:), intent(in) :: field !< A 1-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:), optional, intent(in) :: mask !< An optional rank 1 logical mask + real, dimension(:), optional, intent(in) :: rmask !< An optional rank 1 mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_1d = send_data_fms(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) + +end function send_data_infra_1d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_2d(diag_field_id, field, is_in, ie_in, js_in, je_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:), optional, intent(in) :: mask !< An optional 2-d logical mask + real, dimension(:,:), optional, intent(in) :: rmask !< An optional 2-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_2d = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & + rmask, ie_in, je_in, weight, err_msg) + +end function send_data_infra_2d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_3d(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + integer, optional, intent(in) :: ks_in !< The starting k-index for the data being recorded + integer, optional, intent(in) :: ke_in !< The end k-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:,:), optional, intent(in) :: mask !< An optional 3-d logical mask + real, dimension(:,:,:), optional, intent(in) :: rmask !< An optional 3-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_3d = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, & + rmask, ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_infra_3d + + +#ifdef OVERLOAD_R8 +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:), optional, intent(in) :: mask !< An optional 2-d logical mask + real, dimension(:,:), optional, intent(in) :: rmask !< An optional 2-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_2d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & + rmask, ie_in, je_in, weight, err_msg) + +end function send_data_infra_2d_r8 + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + integer, optional, intent(in) :: ks_in !< The starting k-index for the data being recorded + integer, optional, intent(in) :: ke_in !< The end k-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:,:), optional, intent(in) :: mask !< An optional 3-d logical mask + real, dimension(:,:,:), optional, intent(in) :: rmask !< An optional 3-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_3d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & + ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_infra_3d_r8 +#endif + +!> Add a real scalar attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + real, intent(in) :: att_value !< A real scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_r + +!> Add an integer attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, intent(in) :: att_value !< An integer scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_i + +!> Add a character string attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_c(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + character(len=*), intent(in) :: att_value !< A character string value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_c + +!> Add a real list of attributes attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_r1d(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + real, dimension(:), intent(in) :: att_value !< An array of real values + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_r1d + +!> Add a integer list of attributes attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, dimension(:), intent(in) :: att_value !< An array of integer values + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_i1d + +end module MOM_diag_manager_infra diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 new file mode 100644 index 0000000000..029561946b --- /dev/null +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -0,0 +1,1985 @@ +!> Describes the decomposed MOM domain and has routines for communications across PEs +module MOM_domain_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms_infra, only : PE_here, root_PE, num_PEs +use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL + +use mpp_domains_mod, only : domain2D, domain1D +use mpp_domains_mod, only : mpp_define_io_domain, mpp_define_domains, mpp_deallocate_domain +use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents, mpp_get_layout +use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain +use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains +use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains +use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update +use mpp_domains_mod, only : mpp_reset_group_update_field, mpp_group_update_initialized +use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update +use mpp_domains_mod, only : mpp_compute_block_extent +use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field +use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN, FOLD_NORTH_EDGE +use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE +use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE +use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST +use fms_io_mod, only : file_exist, parse_mask_table +use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get + +! This subroutine is not in MOM6/src but may be required by legacy drivers +use mpp_domains_mod, only : global_field_sum => mpp_global_sum + +! The `group_pass_type` fields are never accessed, so we keep it as an FMS type +use mpp_domains_mod, only : group_pass_type => mpp_group_update_type + +implicit none ; private + +! These types are inherited from mpp, but are treated as opaque here. +public :: domain2D, domain1D, group_pass_type +! These interfaces are actually implemented or have explicit interfaces in this file. +public :: create_MOM_domain, clone_MOM_domain, get_domain_components, get_domain_extent +public :: deallocate_MOM_domain, get_global_shape, compute_block_extent +public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data +public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete +public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass +public :: redistribute_array, broadcast_domain, same_domain, global_field +public :: get_simple_array_i_ind, get_simple_array_j_ind +public :: MOM_thread_affinity_set, set_MOM_thread_affinity +! These are encoding constant parmeters. +public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR +public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +! These are no longer used by MOM6 because the reproducing sum works so well, but they are +! still referenced by some of the non-GFDL couplers. +public :: global_field_sum, BITWISE_EXACT_SUM + +!> Do a halo update on an array +interface pass_var + module procedure pass_var_3d, pass_var_2d +end interface pass_var + +!> Do a halo update on a pair of arrays representing the two components of a vector +interface pass_vector + module procedure pass_vector_3d, pass_vector_2d +end interface pass_vector + +!> Initiate a non-blocking halo update on an array +interface pass_var_start + module procedure pass_var_start_3d, pass_var_start_2d +end interface pass_var_start + +!> Complete a non-blocking halo update on an array +interface pass_var_complete + module procedure pass_var_complete_3d, pass_var_complete_2d +end interface pass_var_complete + +!> Initiate a halo update on a pair of arrays representing the two components of a vector +interface pass_vector_start + module procedure pass_vector_start_3d, pass_vector_start_2d +end interface pass_vector_start + +!> Complete a halo update on a pair of arrays representing the two components of a vector +interface pass_vector_complete + module procedure pass_vector_complete_3d, pass_vector_complete_2d +end interface pass_vector_complete + +!> Set up a group of halo updates +interface create_group_pass + module procedure create_var_group_pass_2d + module procedure create_var_group_pass_3d + module procedure create_vector_group_pass_2d + module procedure create_vector_group_pass_3d +end interface create_group_pass + +!> Do a set of halo updates that fill in the values at the duplicated edges +!! of a staggered symmetric memory domain +interface fill_symmetric_edges + module procedure fill_vector_symmetric_edges_2d !, fill_vector_symmetric_edges_3d +! module procedure fill_scalar_symmetric_edges_2d, fill_scalar_symmetric_edges_3d +end interface fill_symmetric_edges + +!> Rescale the values of an array in its computational domain by a constant factor +interface rescale_comp_data + module procedure rescale_comp_data_4d, rescale_comp_data_3d, rescale_comp_data_2d +end interface rescale_comp_data + +!> Pass an array from one MOM domain to another +interface redistribute_array + module procedure redistribute_array_2d, redistribute_array_3d, redistribute_array_4d +end interface redistribute_array + +!> Copy one MOM_domain_type into another +interface clone_MOM_domain + module procedure clone_MD_to_MD, clone_MD_to_d2D +end interface clone_MOM_domain + +!> Extract the 1-d domain components from a MOM_domain or domain2d +interface get_domain_components + module procedure get_domain_components_MD, get_domain_components_d2D +end interface get_domain_components + +!> Returns the index ranges that have been stored in a MOM_domain_type +interface get_domain_extent + module procedure get_domain_extent_MD, get_domain_extent_d2D +end interface get_domain_extent + + +!> The MOM_domain_type contains information about the domain decomposition. +type, public :: MOM_domain_type + character(len=64) :: name !< The name of this domain + type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos + !! on this processor, centered at h points. + type(domain2D), pointer :: mpp_domain_d2 => NULL() !< A coarse FMS domain with halos + !! on this processor, centered at h points. + integer :: niglobal !< The total horizontal i-domain size. + integer :: njglobal !< The total horizontal j-domain size. + integer :: nihalo !< The i-halo size in memory. + integer :: njhalo !< The j-halo size in memory. + logical :: symmetric !< True if symmetric memory is used with this domain. + logical :: nonblocking_updates !< If true, non-blocking halo updates are + !! allowed. The default is .false. (for now). + logical :: thin_halo_updates !< If true, optional arguments may be used to + !! specify the width of the halos that are + !! updated with each call. + integer :: layout(2) !< This domain's processor layout. This is + !! saved to enable the construction of related + !! new domains with different resolutions or + !! other properties. + integer :: io_layout(2) !< The IO-layout used with this domain. + integer :: X_FLAGS !< Flag that specifies the properties of the + !! domain in the i-direction in a define_domain call. + integer :: Y_FLAGS !< Flag that specifies the properties of the + !! domain in the j-direction in a define_domain call. + logical, pointer :: maskmap(:,:) => NULL() !< A pointer to an array indicating + !! which logical processors are actually used for + !! the ocean code. The other logical processors + !! would be contain only land points and are not + !! assigned to actual processors. This need not be + !! assigned if all logical processors are used. +end type MOM_domain_type + +integer, parameter :: To_All = To_East + To_West + To_North + To_South !< A flag for passing in all directions + +contains + +!> pass_var_3d does a halo update for a three-dimensional array. +subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! sothe halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_3d + +!> pass_var_2d does a halo update for a two-dimensional array. +subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner_halo, clock) + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo + !! by default. + integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, + !! or 0 to avoid updating symmetric memory + !! computational domain points. Setting this >=0 + !! also enforces that complete=.true. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + real, allocatable, dimension(:,:) :: tmp + integer :: pos, i_halo, j_halo + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + integer :: inner, i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + block_til_complete = .true. ; if (present(complete)) block_til_complete = complete + pos = CENTER ; if (present(position)) pos = position + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + ! Store the original values. + allocate(tmp(size(array,1), size(array,2))) + tmp(:,:) = array(:,:) + block_til_complete = .true. + endif ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position) + endif + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + ! Convert to local indices for arrays starting at 1. + isc = isc - (isd-1) ; iec = iec - (isd-1) ; ied = ied - (isd-1) ; isd = 1 + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) ; jed = jed - (jsd-1) ; jsd = 1 + i_halo = min(inner_halo, isc-1) ; j_halo = min(inner_halo, jsc-1) + + ! Figure out the array index extents of the eastern, western, northern and southern regions to copy. + if (pos == CENTER) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CENTER array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CENTER array.") ; endif + elseif (pos == CORNER) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CORNER array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif + elseif (pos == NORTH_FACE) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for NORTH_FACE array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for NORTH_FACE array.") ; endif + elseif (pos == EAST_FACE) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for EAST_FACE array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for EAST_FACE array.") ; endif + else + call MOM_error(FATAL, "pass_var_2d: Unrecognized position") + endif + + ! Copy back the stored inner halo points + do j=jsfs,jefn ; do i=isfw,iefw ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefn ; do i=isfe,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefs ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfn,jefn ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + + deallocate(tmp) + endif ; endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_2d + +!> pass_var_start_2d starts a halo update for a two-dimensional array. +function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_var_start_2d !0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_var_start_2d + +!> pass_var_start_3d starts a halo update for a three-dimensional array. +function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_var_start_3d !< The integer index for this update. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_var_start_3d + +!> pass_var_complete_2d completes a halo update for a two-dimensional array. +subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has + !! been returned from a previous call to + !! pass_var_start. + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_complete_2d + +!> pass_var_complete_3d completes a halo update for a three-dimensional array. +subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has + !! been returned from a previous call to + !! pass_var_start. + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_complete_3d + +!> pass_vector_2d does a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +subroutine pass_vector_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_2d + +!> fill_vector_symmetric_edges_2d does an usual set of halo updates that only +!! fill in the values at the edge of a pair of symmetric memory two-dimensional +!! arrays representing the components of a two-dimensional horizontal vector. +!! If symmetric memory is not being used, this subroutine does nothing except to +!! possibly turn optional cpu clocks on or off. +subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scalar, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: scalar !< An optional argument indicating whether. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + integer :: i, j, isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + real, allocatable, dimension(:) :: sbuff_x, sbuff_y, wbuff_x, wbuff_y + logical :: block_til_complete + + if (.not. MOM_dom%symmetric) then + return + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + if (.not.(stagger_local == CGRID_NE .or. stagger_local == BGRID_NE)) return + + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + + ! Adjust isc, etc., to account for the fact that the input arrays indices all + ! start at 1 (and are effectively on a SW grid!). + isc = isc - (isd-1) ; iec = iec - (isd-1) + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) + IscB = isc ; IecB = iec+1 ; JscB = jsc ; JecB = jec+1 + + dirflag = To_All ! 60 + if (present(scalar)) then ; if (scalar) dirflag = To_All+SCALAR_PAIR ; endif + + if (stagger_local == CGRID_NE) then + allocate(wbuff_x(jsc:jec)) ; allocate(sbuff_y(isc:iec)) + wbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 + call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + wbufferx=wbuff_x, sbuffery=sbuff_y, & + gridtype=CGRID_NE) + do i=isc,iec + v_cmpt(i,JscB) = sbuff_y(i) + enddo + do j=jsc,jec + u_cmpt(IscB,j) = wbuff_x(j) + enddo + deallocate(wbuff_x) ; deallocate(sbuff_y) + elseif (stagger_local == BGRID_NE) then + allocate(wbuff_x(JscB:JecB)) ; allocate(sbuff_x(IscB:IecB)) + allocate(wbuff_y(JscB:JecB)) ; allocate(sbuff_y(IscB:IecB)) + wbuff_x(:) = 0.0 ; wbuff_y(:) = 0.0 ; sbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 + call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + wbufferx=wbuff_x, sbufferx=sbuff_x, & + wbuffery=wbuff_y, sbuffery=sbuff_y, & + gridtype=BGRID_NE) + do I=IscB,IecB + u_cmpt(I,JscB) = sbuff_x(I) ; v_cmpt(I,JscB) = sbuff_y(I) + enddo + do J=JscB,JecB + u_cmpt(IscB,J) = wbuff_x(J) ; v_cmpt(IscB,J) = wbuff_y(J) + enddo + deallocate(wbuff_x) ; deallocate(sbuff_x) + deallocate(wbuff_y) ; deallocate(sbuff_y) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine fill_vector_symmetric_edges_2d + +!> pass_vector_3d does a halo update for a pair of three-dimensional arrays +!! representing the components of a three-dimensional horizontal vector. +subroutine pass_vector_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_3d + +!> pass_vector_start_2d starts a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +function pass_vector_start_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_vector_start_2d !< The integer index for this + !! update. + + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_vector_start_2d + +!> pass_vector_start_3d starts a halo update for a pair of three-dimensional arrays +!! representing the components of a three-dimensional horizontal vector. +function pass_vector_start_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_vector_start_3d !< The integer index for this + !! update. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_vector_start_3d + +!> pass_vector_complete_2d completes a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +subroutine pass_vector_complete_2d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has been + !! returned from a previous call to + !! pass_var_start. + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_complete_2d + +!> pass_vector_complete_3d completes a halo update for a pair of three-dimensional +!! arrays representing the components of a three-dimensional horizontal vector. +subroutine pass_vector_complete_3d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has been + !! returned from a previous call to + !! pass_var_start. + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_complete_3d + +!> create_var_group_pass_2d sets up a group of two-dimensional array halo updates. +subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, & + halo, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_var_group_pass_2d + +!> create_var_group_pass_3d sets up a group of three-dimensional array halo updates. +subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_var_group_pass_3d + +!> create_vector_group_pass_2d sets up a group of two-dimensional vector halo updates. +subroutine create_vector_group_pass_2d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_vector_group_pass_2d + +!> create_vector_group_pass_3d sets up a group of three-dimensional vector halo updates. +subroutine create_vector_group_pass_3d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_vector_group_pass_3d + +!> do_group_pass carries out a group halo update. +subroutine do_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine do_group_pass + +!> start_group_pass starts out a group halo update. +subroutine start_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_start_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine start_group_pass + +!> complete_group_pass completes a group halo update. +subroutine complete_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_complete_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine complete_group_pass + + +!> Pass a 2-D array from one MOM domain to another +subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_2d + +!> Pass a 3-D array from one MOM domain to another +subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_3d + +!> Pass a 4-D array from one MOM domain to another +subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_4d + + +!> Rescale the values of a 4-D array in its computational domain by a constant factor +subroutine rescale_comp_data_4d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:,:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je,:,:) = scale*array(is:ie,js:je,:,:) + +end subroutine rescale_comp_data_4d + +!> Rescale the values of a 3-D array in its computational domain by a constant factor +subroutine rescale_comp_data_3d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je,:) = scale*array(is:ie,js:je,:) + +end subroutine rescale_comp_data_3d + +!> Rescale the values of a 2-D array in its computational domain by a constant factor +subroutine rescale_comp_data_2d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je) = scale*array(is:ie,js:je) + +end subroutine rescale_comp_data_2d + +!> create_MOM_domain creates and initializes a MOM_domain_type variables, based on the information +!! provided in arguments. +subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, io_layout, & + domain_name, mask_table, symmetric, thin_halos, nonblocking) + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type being defined here. + integer, dimension(2), intent(in) :: n_global !< The number of points on the global grid in + !! the i- and j-directions + integer, dimension(2), intent(in) :: n_halo !< The number of halo points on each processor + logical, dimension(2), intent(in) :: reentrant !< If true the grid is periodic in the i- and j- directions + logical, intent(in) :: tripolar_N !< If true the grid uses northern tripolar connectivity + integer, dimension(2), intent(in) :: layout !< The layout of logical PEs in the i- and j-directions. + integer, dimension(2), optional, intent(in) :: io_layout !< The layout for parallel input and output. + character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" if missing. + character(len=*), optional, intent(in) :: mask_table !< The full relative or absolute path to the mask table. + logical, optional, intent(in) :: symmetric !< If present, this specifies whether this domain + !! uses symmetric memory, or true if missing. + logical, optional, intent(in) :: thin_halos !< If present, this specifies whether to permit the use of + !! thin halo updates, or true if missing. + logical, optional, intent(in) :: nonblocking !< If present, this specifies whether to permit the use of + !! nonblocking halo updates, or false if missing. + + ! local variables + integer, dimension(4) :: global_indices ! The lower and upper global i- and j-index bounds + integer :: X_FLAGS ! A combination of integers encoding the x-direction grid connectivity. + integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity. + integer :: xhalo_d2, yhalo_d2 + character(len=200) :: mesg ! A string for use in error messages + logical :: mask_table_exists ! Mask_table is present and the file it points to exists + + if (.not.associated(MOM_dom)) then + allocate(MOM_dom) + allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) + endif + + MOM_dom%name = "MOM" ; if (present(domain_name)) MOM_dom%name = trim(domain_name) + + X_FLAGS = 0 ; Y_FLAGS = 0 + if (reentrant(1)) X_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (reentrant(2)) Y_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (tripolar_N) then + Y_FLAGS = FOLD_NORTH_EDGE + if (reentrant(2)) call MOM_error(FATAL,"MOM_domains: "// & + "TRIPOLAR_N and REENTRANT_Y may not be used together.") + endif + + MOM_dom%nonblocking_updates = nonblocking + MOM_dom%thin_halo_updates = thin_halos + MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric + MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) + MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) + + ! Save the extra data for creating other domains of different resolution that overlay this domain. + MOM_dom%X_FLAGS = X_FLAGS + MOM_dom%Y_FLAGS = Y_FLAGS + MOM_dom%layout(:) = layout(:) + + ! Set up the io_layout, with error handling. + MOM_dom%io_layout(:) = (/ 1, 1 /) + if (present(io_layout)) then + if (io_layout(1) == 0) then + MOM_dom%io_layout(1) = layout(1) + elseif (io_layout(1) > 1) then + MOM_dom%io_layout(1) = io_layout(1) + if (modulo(layout(1), io_layout(1)) /= 0) then + write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & + &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') io_layout(1), layout(1) + call MOM_error(FATAL, mesg) + endif + endif + + if (io_layout(2) == 0) then + MOM_dom%io_layout(2) = layout(2) + elseif (io_layout(2) > 1) then + MOM_dom%io_layout(2) = io_layout(2) + if (modulo(layout(2), io_layout(2)) /= 0) then + write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & + &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') io_layout(2), layout(2) + call MOM_error(FATAL, mesg) + endif + endif + endif + + if (present(mask_table)) then + mask_table_exists = file_exist(mask_table) + if (mask_table_exists) then + allocate(MOM_dom%maskmap(layout(1), layout(2))) + call parse_mask_table(mask_table, MOM_dom%maskmap, MOM_dom%name) + endif + else + mask_table_exists = .false. + endif + + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain) + + !For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations. + !But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get + !error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27 + ! call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, halo_size=(MOM_dom%nihalo/2), coarsen=2) + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, coarsen=2) + +end subroutine create_MOM_domain + +!> dealloc_MOM_domain deallocates memory associated with a pointer to a MOM_domain_type +!! and potentially all of its contents +subroutine deallocate_MOM_domain(MOM_domain, cursory) + type(MOM_domain_type), pointer :: MOM_domain !< A pointer to the MOM_domain_type being deallocated + logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated + !! with the underlying infrastructure + logical :: invasive ! If true, deallocate fields associated with the underlying infrastructure + + invasive = .true. ; if (present(cursory)) invasive = .not.cursory + + if (associated(MOM_domain)) then + if (associated(MOM_domain%mpp_domain)) then + if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain) + deallocate(MOM_domain%mpp_domain) + endif + if (associated(MOM_domain%mpp_domain_d2)) then + if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain_d2) + deallocate(MOM_domain%mpp_domain_d2) + endif + if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) + deallocate(MOM_domain) + endif + +end subroutine deallocate_MOM_domain + +!> MOM_thread_affinity_set returns true if the number of openMP threads have been set to a value greater than 1. +function MOM_thread_affinity_set() + ! Local variables + !$ integer :: ocean_nthreads ! Number of openMP threads + !$ integer :: omp_get_num_threads ! An openMP function that returns the number of threads + logical :: MOM_thread_affinity_set + + MOM_thread_affinity_set = .false. + !$ call fms_affinity_init() + !$OMP PARALLEL + !$OMP MASTER + !$ ocean_nthreads = omp_get_num_threads() + !$OMP END MASTER + !$OMP END PARALLEL + !$ MOM_thread_affinity_set = (ocean_nthreads > 1 ) +end function MOM_thread_affinity_set + +!> set_MOM_thread_affinity sets the number of openMP threads to use with the ocean. +subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread) + integer, intent(in) :: ocean_nthreads !< Number of openMP threads to use for the ocean model + logical, intent(in) :: ocean_hyper_thread !< If true, use hyper threading + + ! Local variables + !$ integer :: omp_get_thread_num, omp_get_num_threads !< These are the results of openMP functions + + !$ call fms_affinity_init() ! fms_affinity_init can be safely called more than once. + !$ call fms_affinity_set('OCEAN', ocean_hyper_thread, ocean_nthreads) + !$ call omp_set_num_threads(ocean_nthreads) + !$OMP PARALLEL + !$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() + !$ flush(6) + !$OMP END PARALLEL +end subroutine set_MOM_thread_affinity + +!> This subroutine retrieves the 1-d domains that make up the 2d-domain in a MOM_domain +subroutine get_domain_components_MD(MOM_dom, x_domain, y_domain) + type(MOM_domain_type), intent(in) :: MOM_dom !< The MOM_domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(MOM_dom%mpp_domain, x_domain, y_domain) +end subroutine get_domain_components_MD + +!> This subroutine retrieves the 1-d domains that make up a 2d-domain +subroutine get_domain_components_d2D(domain, x_domain, y_domain) + type(domain2D), intent(in) :: domain !< The 2D domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(domain, x_domain, y_domain) +end subroutine get_domain_components_d2D + +!> clone_MD_to_MD copies one MOM_domain_type into another, while allowing +!! some properties of the new type to differ from the original one. +subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, & + turns, refine, extra_halo) + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be + !! allocated if it is unassociated, and will have data + !! copied from MD_in + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domain in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, copied + !! from MD_in if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns + integer, optional, intent(in) :: refine !< A factor by which to enhance the grid resolution. + integer, optional, intent(in) :: extra_halo !< An extra number of points in the halos + !! compared with MD_in + + integer :: global_indices(4) + logical :: mask_table_exists + integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout. + ! The sum of exni must equal MOM_dom%niglobal. + integer, dimension(:), allocatable :: exnj ! The extents of the grid for each j-row of the layout. + ! The sum of exni must equal MOM_dom%niglobal. + integer :: qturns ! The number of quarter turns, restricted to the range of 0 to 3. + integer :: i, j, nl1, nl2 + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (.not.associated(MOM_dom)) then + allocate(MOM_dom) + allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) + endif + +! Save the extra data for creating other domains of different resolution that overlay this domain + MOM_dom%symmetric = MD_in%symmetric + MOM_dom%nonblocking_updates = MD_in%nonblocking_updates + MOM_dom%thin_halo_updates = MD_in%thin_halo_updates + + if (modulo(qturns, 2) /= 0) then + MOM_dom%niglobal = MD_in%njglobal ; MOM_dom%njglobal = MD_in%niglobal + MOM_dom%nihalo = MD_in%njhalo ; MOM_dom%njhalo = MD_in%nihalo + call get_layout_extents(MD_in, exnj, exni) + + MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS + MOM_dom%layout(:) = MD_in%layout(2:1:-1) + MOM_dom%io_layout(:) = MD_in%io_layout(2:1:-1) + else + MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal + MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo + call get_layout_extents(MD_in, exni, exnj) + + MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS + MOM_dom%layout(:) = MD_in%layout(:) + MOM_dom%io_layout(:) = MD_in%io_layout(:) + endif + + ! Ensure that the points per processor are the same on the source and densitation grids. + select case (qturns) + case (1) ; call invert(exni) + case (2) ; call invert(exni) ; call invert(exnj) + case (3) ; call invert(exnj) + end select + + if (associated(MD_in%maskmap)) then + mask_table_exists = .true. + allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2))) + + nl1 = MOM_dom%layout(1) ; nl2 = MOM_dom%layout(2) + select case (qturns) + case (0) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(i, j) + enddo ; enddo + case (1) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(j, nl1+1-i) + enddo ; enddo + case (2) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(nl1+1-i, nl2+1-j) + enddo ; enddo + case (3) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(nl2+1-j, i) + enddo ; enddo + end select + else + mask_table_exists = .false. + endif + + ! Optionally enhance the grid resolution. + if (present(refine)) then ; if (refine > 1) then + MOM_dom%niglobal = refine*MOM_dom%niglobal ; MOM_dom%njglobal = refine*MOM_dom%njglobal + MOM_dom%nihalo = refine*MOM_dom%nihalo ; MOM_dom%njhalo = refine*MOM_dom%njhalo + do i=1,MOM_dom%layout(1) ; exni(i) = refine*exni(i) ; enddo + do j=1,MOM_dom%layout(2) ; exnj(j) = refine*exnj(j) ; enddo + endif ; endif + + ! Optionally enhance the grid resolution. + if (present(extra_halo)) then ; if (extra_halo > 0) then + MOM_dom%nihalo = MOM_dom%nihalo + extra_halo ; MOM_dom%njhalo = MOM_dom%njhalo + extra_halo + endif ; endif + + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & + "clone_MOM_domain can not have both halo_size and min_halo present.") + + if (present(min_halo)) then + MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) + min_halo(1) = MOM_dom%nihalo + MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) + min_halo(2) = MOM_dom%njhalo + endif + + if (present(halo_size)) then + MOM_dom%nihalo = halo_size ; MOM_dom%njhalo = halo_size + endif + + if (present(symmetric)) then ; MOM_dom%symmetric = symmetric ; endif + + if (present(domain_name)) then + MOM_dom%name = trim(domain_name) + else + MOM_dom%name = MD_in%name + endif + + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain, xextent=exni, yextent=exnj) + + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, domain_name=MOM_dom%name, coarsen=2) + +end subroutine clone_MD_to_MD + + +!> clone_MD_to_d2D uses information from a MOM_domain_type to create a new +!! domain2d type, while allowing some properties of the new type to differ from +!! the original one. +subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & + domain_name, turns, xextent, yextent, coarsen) + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned + type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domain in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined or + !! whether MD_in is symmetric. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns - not implemented here. + integer, optional, intent(in) :: coarsen !< A factor by which to coarsen this grid. + !! The default of 1 is for no coarsening. + integer, dimension(:), optional, intent(in) :: xextent !< The number of grid points in the + !! tracer computational domain for division of the x-layout. + integer, dimension(:), optional, intent(in) :: yextent !< The number of grid points in the + !! tracer computational domain for division of the y-layout. + + integer :: global_indices(4) + integer :: nihalo, njhalo + logical :: symmetric_dom, do_coarsen + character(len=64) :: dom_name + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for MOM_domain to domain2d") + + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & + "clone_MOM_domain can not have both halo_size and min_halo present.") + + do_coarsen = .false. ; if (present(coarsen)) then ; do_coarsen = (coarsen > 1) ; endif + + nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo + if (do_coarsen) then + nihalo = int(MD_in%nihalo / coarsen) ; njhalo = int(MD_in%njhalo / coarsen) + endif + + if (present(min_halo)) then + nihalo = max(nihalo, min_halo(1)) + njhalo = max(njhalo, min_halo(2)) + min_halo(1) = nihalo ; min_halo(2) = njhalo + endif + if (present(halo_size)) then + nihalo = halo_size ; njhalo = halo_size + endif + + symmetric_dom = MD_in%symmetric + if (present(symmetric)) then ; symmetric_dom = symmetric ; endif + + dom_name = MD_in%name + if (do_coarsen) dom_name = trim(MD_in%name)//"c" + if (present(domain_name)) dom_name = trim(domain_name) + + global_indices(1:4) = (/ 1, MD_in%niglobal, 1, MD_in%njglobal /) + if (do_coarsen) then + global_indices(1:4) = (/ 1, (MD_in%niglobal/coarsen), 1, (MD_in%njglobal/coarsen) /) + endif + + if (associated(MD_in%maskmap)) then + call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, & + xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & + xextent=xextent, yextent=yextent, symmetry=symmetric_dom, name=dom_name, & + maskmap=MD_in%maskmap ) + else + call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, & + xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & + symmetry=symmetric_dom, xextent=xextent, yextent=yextent, name=dom_name) + endif + + if ((MD_in%io_layout(1) + MD_in%io_layout(2) > 0) .and. & + (MD_in%layout(1)*MD_in%layout(2) > 1)) then + call mpp_define_io_domain(mpp_domain, MD_in%io_layout) + else + call mpp_define_io_domain(mpp_domain, (/ 1, 1 /) ) + endif + +end subroutine clone_MD_to_d2D + +!> Returns the index ranges that have been stored in a MOM_domain_type +subroutine get_domain_extent_MD(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & + isg, ieg, jsg, jeg, idg_offset, jdg_offset, & + symmetric, local_indexing, index_offset, coarsen) + type(MOM_domain_type), & + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, intent(out) :: isd !< The start i-index of the data domain + integer, intent(out) :: ied !< The end i-index of the data domain + integer, intent(out) :: jsd !< The start j-index of the data domain + integer, intent(out) :: jed !< The end j-index of the data domain + integer, optional, intent(out) :: isg !< The start i-index of the global domain + integer, optional, intent(out) :: ieg !< The end i-index of the global domain + integer, optional, intent(out) :: jsg !< The start j-index of the global domain + integer, optional, intent(out) :: jeg !< The end j-index of the global domain + integer, optional, intent(out) :: idg_offset !< The offset between the corresponding global and + !! data i-index spaces. + integer, optional, intent(out) :: jdg_offset !< The offset between the corresponding global and + !! data j-index spaces. + logical, optional, intent(out) :: symmetric !< True if symmetric memory is used. + logical, optional, intent(in) :: local_indexing !< If true, local tracer array indices start at 1, + !! as in most MOM6 code. The default is true. + integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices. This + !! can be useful for some types of debugging with + !! dynamic memory allocation. The default is 0. + integer, optional, intent(in) :: coarsen !< A factor by which the grid is coarsened. + !! The default is 1, for no coarsening. + + ! Local variables + integer :: isg_, ieg_, jsg_, jeg_ + integer :: ind_off, idg_off, jdg_off, coarsen_lev + logical :: local + + local = .true. ; if (present(local_indexing)) local = local_indexing + ind_off = 0 ; if (present(index_offset)) ind_off = index_offset + + coarsen_lev = 1 ; if (present(coarsen)) coarsen_lev = coarsen + + if (coarsen_lev == 1) then + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + call mpp_get_global_domain(Domain%mpp_domain, isg_, ieg_, jsg_, jeg_) + elseif (coarsen_lev == 2) then + if (.not.associated(Domain%mpp_domain_d2)) call MOM_error(FATAL, & + "get_domain_extent called with coarsen=2, but Domain%mpp_domain_d2 is not associated.") + call mpp_get_compute_domain(Domain%mpp_domain_d2, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain_d2, isd, ied, jsd, jed) + call mpp_get_global_domain(Domain%mpp_domain_d2, isg_, ieg_, jsg_, jeg_) + else + call MOM_error(FATAL, "get_domain_extent called with an unsupported level of coarsening.") + endif + + if (local) then + ! This code institutes the MOM convention that local array indices start at 1. + idg_off = isd - 1 ; jdg_off = jsd - 1 + isc = isc - isd + 1 ; iec = iec - isd + 1 ; jsc = jsc - jsd + 1 ; jec = jec - jsd + 1 + ied = ied - isd + 1 ; jed = jed - jsd + 1 + isd = 1 ; jsd = 1 + else + idg_off = 0 ; jdg_off = 0 + endif + if (ind_off /= 0) then + idg_off = idg_off + ind_off ; jdg_off = jdg_off + ind_off + isc = isc + ind_off ; iec = iec + ind_off + jsc = jsc + ind_off ; jec = jec + ind_off + isd = isd + ind_off ; ied = ied + ind_off + jsd = jsd + ind_off ; jed = jed + ind_off + endif + if (present(isg)) isg = isg_ + if (present(ieg)) ieg = ieg_ + if (present(jsg)) jsg = jsg_ + if (present(jeg)) jeg = jeg_ + if (present(idg_offset)) idg_offset = idg_off + if (present(jdg_offset)) jdg_offset = jdg_off + if (present(symmetric)) symmetric = Domain%symmetric + +end subroutine get_domain_extent_MD + +!> Returns the index ranges that have been stored in a domain2D type +subroutine get_domain_extent_d2D(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed) + type(domain2d), intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, optional, intent(out) :: isd !< The start i-index of the data domain + integer, optional, intent(out) :: ied !< The end i-index of the data domain + integer, optional, intent(out) :: jsd !< The start j-index of the data domain + integer, optional, intent(out) :: jed !< The end j-index of the data domain + + ! Local variables + integer :: isd_, ied_, jsd_, jed_, jsg_, jeg_, isg_, ieg_ + + call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain, isd_, ied_, jsd_, jed_) + + if (present(isd)) isd = isd_ + if (present(ied)) ied = ied_ + if (present(jsd)) jsd = jsd_ + if (present(jed)) jed = jed_ + +end subroutine get_domain_extent_d2D + +!> Return the (potentially symmetric) computational domain i-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_i_ind(domain, size, is, ie, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The i-array size + integer, intent(out) :: is !< The computational domain starting i-index. + integer, intent(out) :: ie !< The computational domain ending i-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + isc = isc-isd+1 ; iec = iec-isd+1 ; ied = ied-isd+1 ; isd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == ied) then ; is = isc ; ie = iec + elseif (size == 1+iec-isc) then ; is = 1 ; ie = size + elseif (sym .and. (size == 1+ied)) then ; is = isc ; ie = iec+1 + elseif (sym .and. (size == 2+iec-isc)) then ; is = 1 ; ie = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_i_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') ied, 1+iec-isc + else + write(mesg2,'("Valid sizes are : ", 4i7)') ied, 1+iec-isc, 1+ied, 2+iec-isc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_i_ind + + +!> Return the (potentially symmetric) computational domain j-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_j_ind(domain, size, js, je, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The j-array size + integer, intent(out) :: js !< The computational domain starting j-index. + integer, intent(out) :: je !< The computational domain ending j-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + jsc = jsc-jsd+1 ; jec = jec-jsd+1 ; jed = jed-jsd+1 ; jsd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == jed) then ; js = jsc ; je = jec + elseif (size == 1+jec-jsc) then ; js = 1 ; je = size + elseif (sym .and. (size == 1+jed)) then ; js = jsc ; je = jec+1 + elseif (sym .and. (size == 2+jec-jsc)) then ; js = 1 ; je = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_j_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') jed, 1+jec-jsc + else + write(mesg2,'("Valid sizes are : ", 4i7)') jed, 1+jec-jsc, 1+jed, 2+jec-jsc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_j_ind + +!> Invert the contents of a 1-d array +subroutine invert(array) + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo +end subroutine invert + +!> Returns the global shape of h-point arrays +subroutine get_global_shape(domain, niglobal, njglobal) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(out) :: niglobal !< i-index global size of h-point arrays + integer, intent(out) :: njglobal !< j-index global size of h-point arrays + + niglobal = domain%niglobal + njglobal = domain%njglobal +end subroutine get_global_shape + +!> Get the array ranges in one dimension for the divisions of a global index space +subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend) + integer, intent(in) :: isg !< The starting index of the global index space + integer, intent(in) :: ieg !< The ending index of the global index space + integer, intent(in) :: ndivs !< The number of divisions + integer, dimension(:), intent(out) :: ibegin !< The starting index of each division + integer, dimension(:), intent(out) :: iend !< The ending index of each division + + call mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_block_extent + +!> Broadcast a 2-d domain from the root PE to the other PEs +subroutine broadcast_domain(domain) + type(domain2d), intent(inout) :: domain !< The domain2d type that will be shared across PEs. + + call mpp_broadcast_domain(domain) +end subroutine broadcast_domain + +!> Broadcast an entire 2-d array from the root processor to all others. +subroutine global_field(domain, local, global) + type(domain2d), intent(inout) :: domain !< The domain2d type that describes the decomposition + real, dimension(:,:), intent(in) :: local !< The portion of the array on the local PE + real, dimension(:,:), intent(out) :: global !< The whole global array + + call mpp_global_field(domain, local, global) +end subroutine global_field + +!> same_domain returns true if two domains use the same list of PEs and layouts and have the same +!! size computational domains, and false if the domains do not conform with each other. +!! Different halo sizes or indexing conventions do not alter the results. +logical function same_domain(domain_a, domain_b) + type(domain2D), intent(in) :: domain_a !< The first domain in the comparison + type(domain2D), intent(in) :: domain_b !< The second domain in the comparison + + ! Local variables + integer :: isc_a, iec_a, jsc_a, jec_a, isc_b, iec_b, jsc_b, jec_b + integer :: layout_a(2), layout_b(2) + + ! This routine currently does a few checks for consistent domains; more could be added. + call mpp_get_layout(domain_a, layout_a) + call mpp_get_layout(domain_b, layout_b) + + call get_domain_extent(domain_a, isc_a, iec_a, jsc_a, jec_a) + call get_domain_extent(domain_b, isc_b, iec_b, jsc_b, jec_b) + + same_domain = (layout_a(1) == layout_b(1)) .and. (layout_a(2) == layout_b(2)) .and. & + (iec_a - isc_a == iec_b - isc_b) .and. (jec_a - jsc_a == jec_b - jsc_b) + +end function same_domain + +!> Returns arrays of the i- and j- sizes of the h-point computational domains for each +!! element of the grid layout. Any input values in the extent arrays are discarded, so +!! they are effectively intent out despite their declared intent of inout. +subroutine get_layout_extents(Domain, extent_i, extent_j) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, dimension(:), allocatable, intent(inout) :: extent_i !< The number of points in the + !! i-direction in each i-row of the layout + integer, dimension(:), allocatable, intent(inout) :: extent_j !< The number of points in the + !! j-direction in each j-row of the layout + + if (allocated(extent_i)) deallocate(extent_i) + if (allocated(extent_j)) deallocate(extent_j) + allocate(extent_i(domain%layout(1))) ; extent_i(:) = 0 + allocate(extent_j(domain%layout(2))) ; extent_j(:) = 0 + call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) +end subroutine get_layout_extents + +end module MOM_domain_infra diff --git a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 new file mode 100644 index 0000000000..66bbb86e2f --- /dev/null +++ b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 @@ -0,0 +1,95 @@ +!> A simple (very thin) wrapper for managing ensemble member layout information +module MOM_ensemble_manager_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use ensemble_manager_mod, only : FMS_ensemble_manager_init => ensemble_manager_init +use ensemble_manager_mod, only : FMS_ensemble_pelist_setup => ensemble_pelist_setup +use ensemble_manager_mod, only : FMS_get_ensemble_id => get_ensemble_id +use ensemble_manager_mod, only : FMS_get_ensemble_size => get_ensemble_size +use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist +use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist + +implicit none ; private + +public :: ensemble_manager_init, ensemble_pelist_setup +public :: get_ensemble_id, get_ensemble_size +public :: get_ensemble_pelist, get_ensemble_filter_pelist + +contains + +!> Initializes the ensemble manager which divides available resources +!! in order to concurrently execute an ensemble of model realizations. +subroutine ensemble_manager_init() + + call FMS_ensemble_manager_init() + +end subroutine ensemble_manager_init + +!> Create a list of processing elements (PEs) across components +!! associated with the current ensemble member. +subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, & + Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist) + logical, intent(in) :: concurrent !< A logical flag, if True, then ocean fast + !! PEs are run concurrently with + !! slow PEs within the coupler. + integer, intent(in) :: atmos_npes !< The number of atmospheric (fast) PEs + integer, intent(in) :: ocean_npes !< The number of ocean (slow) PEs + integer, intent(in) :: land_npes !< The number of land PEs (fast) + integer, intent(in) :: ice_npes !< The number of ice (fast) PEs + integer, dimension(:), intent(inout) :: Atm_pelist !< A list of Atm PEs + integer, dimension(:), intent(inout) :: Ocean_pelist !< A list of Ocean PEs + integer, dimension(:), intent(inout) :: Land_pelist !< A list of Land PEs + integer, dimension(:), intent(inout) :: Ice_pelist !< A list of Ice PEs + + + call FMS_ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, & + Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist) + +end subroutine ensemble_pelist_setup + +!> Returns the numeric id for the current ensemble member +function get_ensemble_id() + integer :: get_ensemble_id + + get_ensemble_id = FMS_get_ensemble_id() + +end function get_ensemble_id + +!> Returns ensemble information as follows, +!! index (1) :: ensemble size +!! index (2) :: Number of PEs per ensemble member +!! index (3) :: Number of ocean PEs per ensemble member +!! index (4) :: Number of atmos PEs per ensemble member +!! index (5) :: Number of land PEs per ensemble member +!! index (6) :: Number of ice PEs per ensemble member +function get_ensemble_size() + integer, dimension(6) :: get_ensemble_size + + get_ensemble_size = FMS_get_ensemble_size() + +end function get_ensemble_size + +!> Returns the list of PEs associated with all ensemble members +!! Results are stored in the argument array which must be large +!! enough to contain the list. If the optional name argument is present, +!! the returned processor list are for a particular component (atmos, ocean ,land, ice) +subroutine get_ensemble_pelist(pelist, name) + integer, intent(inout) :: pelist(:,:) !< A processor list for all ensemble members + character(len=*), optional, intent(in) :: name !< An optional component name (atmos, ocean, land, ice) + + call FMS_get_ensemble_pelist(pelist, name) + +end subroutine get_ensemble_pelist + +!> Returns the list of PEs associated with the named ensemble filter application. +!! Valid component names include ('atmos', 'ocean', 'land', and 'ice') +subroutine get_ensemble_filter_pelist(pelist, name) + integer, intent(inout) :: pelist(:) !< A processor list for the ensemble filter + character(len=*), intent(in) :: name !< The component name (atmos, ocean, land, ice) + + call FMS_get_Ensemble_filter_pelist(pelist, name) + +end subroutine get_ensemble_filter_pelist + +end module MOM_ensemble_manager_infra diff --git a/config_src/infra/FMS2/MOM_error_infra.F90 b/config_src/infra/FMS2/MOM_error_infra.F90 new file mode 100644 index 0000000000..e5a8b8dc68 --- /dev/null +++ b/config_src/infra/FMS2/MOM_error_infra.F90 @@ -0,0 +1,42 @@ +!> Routines for error handling and I/O management +module MOM_error_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use mpp_mod, only : mpp_error, mpp_pe, mpp_root_pe, mpp_stdlog=>stdlog, mpp_stdout=>stdout +use mpp_mod, only : NOTE, WARNING, FATAL + +implicit none ; private + +public :: MOM_err, is_root_pe, stdlog, stdout +!> Integer parameters encoding the severity of an error message +public :: NOTE, WARNING, FATAL + +contains + +!> MOM_err writes an error message, and may cause the run to stop depending on the +!! severity of the error. +subroutine MOM_err(severity, message) + integer, intent(in) :: severity !< The severity level of this error + character(len=*), intent(in) :: message !< A message to write out + + call mpp_error(severity, message) +end subroutine MOM_err + +!> stdout returns the standard Fortran unit number for output +integer function stdout() + stdout = mpp_stdout() +end function stdout + +!> stdlog returns the standard Fortran unit number to use to log messages +integer function stdlog() + stdlog = mpp_stdlog() +end function stdlog + +!> is_root_pe returns .true. if the current PE is the root PE. +logical function is_root_pe() + is_root_pe = .false. + if (mpp_pe() == mpp_root_pe()) is_root_pe = .true. +end function is_root_pe + +end module MOM_error_infra diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 new file mode 100644 index 0000000000..170573f7ec --- /dev/null +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -0,0 +1,260 @@ +!> This module wraps the FMS temporal and spatial interpolation routines +module MOM_interp_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_time_manager, only : time_type +use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type +use mpp_io_mod, only : axistype, mpp_get_axis_data +use time_interp_external_mod, only : time_interp_external +use time_interp_external_mod, only : init_external_field, time_interp_external_init +use time_interp_external_mod, only : get_external_field_size +use time_interp_external_mod, only : get_external_field_axes, get_external_field_missing + +implicit none ; private + +public :: horiz_interp_type, horiz_interp_init +public :: time_interp_extern, init_extern_field, time_interp_external_init +public :: get_external_field_info, axistype, get_axis_data +public :: run_horiz_interp, build_horiz_interp_weights + +!> Read a field based on model time, and rotate to the model domain. +interface time_interp_extern + module procedure time_interp_extern_0d + module procedure time_interp_extern_2d + module procedure time_interp_extern_3d +end interface time_interp_extern + +!> perform horizontal interpolation of field +interface run_horiz_interp + module procedure horiz_interp_from_weights_field2d + module procedure horiz_interp_from_weights_field3d +end interface + +!> build weights for horizontal interpolation of field +interface build_horiz_interp_weights + module procedure build_horiz_interp_weights_2d_to_2d +end interface build_horiz_interp_weights + +contains + +!> perform horizontal interpolation of a 2d field using pre-computed weights +!! source and destination coordinates are 2d +subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation options and weights + real, dimension(:,:), intent(in) :: data_in !< input data + real, dimension(:,:), intent(out) :: data_out !< output data + integer, optional, intent(in) :: verbose !< verbosity level + real, dimension(:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:), optional, intent(out) :: mask_out !< mask for output data + real, optional, intent(in) :: missing_value !< A value indicating missing data + integer, optional, intent(in) :: missing_permit !< number of allowed points with + !! missing value for interpolation (0-3) + character(len=*), optional, intent(out) :: err_msg !< error message + + call horiz_interp(Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit, & + err_msg, new_missing_handle=.true. ) + +end subroutine horiz_interp_from_weights_field2d + + +!> perform horizontal interpolation of a 3d field using pre-computed weights +!! source and destination coordinates are 2d +subroutine horiz_interp_from_weights_field3d(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation options and weights + real, dimension(:,:,:), intent(in) :: data_in !< input data + real, dimension(:,:,:), intent(out) :: data_out !< output data + integer, optional, intent(in) :: verbose !< verbosity level + real, dimension(:,:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:,:), optional, intent(out) :: mask_out !< mask for output data + real, optional, intent(in) :: missing_value !< A value indicating missing data + integer, optional, intent(in) :: missing_permit !< number of allowed points with + !! missing value for interpolation (0-3) + character(len=*), optional, intent(out) :: err_msg !< error message + + call horiz_interp(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + +end subroutine horiz_interp_from_weights_field3d + + +!> build horizontal interpolation weights from source grid defined by 2d lon/lat to destination grid +!! defined by 2d lon/lat +subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, & + is_latlon_in, is_latlon_out) + + type(horiz_interp_type), intent(inout) :: Interp !< type containing interpolation options and weights + real, dimension(:,:), intent(in) :: lon_in !< input longitude 2d + real, dimension(:,:), intent(in) :: lat_in !< input latitude 2d + real, dimension(:,:), intent(in) :: lon_out !< output longitude 2d + real, dimension(:,:), intent(in) :: lat_out !< output latitude 2d + integer, optional, intent(in) :: verbose !< verbosity level + character(len=*), optional, intent(in) :: interp_method !< interpolation method + integer, optional, intent(in) :: num_nbrs !< number of nearest neighbors + real, optional, intent(in) :: max_dist !< maximum region of influence + logical, optional, intent(in) :: src_modulo !< periodicity of E-W boundary + real, dimension(:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:), optional, intent(inout) :: mask_out !< mask for output data + logical, optional, intent(in) :: is_latlon_in !< input grid is regular lat/lon grid + logical, optional, intent(in) :: is_latlon_out !< output grid is regular lat/lon grid + + call horiz_interp_new(Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, & + is_latlon_in, is_latlon_out) + +end subroutine build_horiz_interp_weights_2d_to_2d + + +!> Extracts and returns the axis data stored in an axistype. +subroutine get_axis_data( axis, dat ) + type(axistype), intent(in) :: axis !< An axis type + real, dimension(:), intent(out) :: dat !< The data in the axis variable + + call mpp_get_axis_data( axis, dat ) +end subroutine get_axis_data + + +!> get size of an external field from field index +function get_extern_field_size(index) + + integer, intent(in) :: index !< field index + integer :: get_extern_field_size(4) !< field size + + get_extern_field_size = get_external_field_size(index) + +end function get_extern_field_size + + +!> get axes of an external field from field index +function get_extern_field_axes(index) + + integer, intent(in) :: index !< field index + type(axistype), dimension(4) :: get_extern_field_axes !< field axes + + get_extern_field_axes = get_external_field_axes(index) + +end function get_extern_field_axes + + +!> get missing value of an external field from field index +function get_extern_field_missing(index) + + integer, intent(in) :: index !< field index + real :: get_extern_field_missing !< field missing value + + get_extern_field_missing = get_external_field_missing(index) + +end function get_extern_field_missing + + +!> Get information about the external fields. +subroutine get_external_field_info(field_id, size, axes, missing) + integer, intent(in) :: field_id !< The integer index of the external + !! field returned from a previous + !! call to init_external_field() + integer, dimension(4), optional, intent(inout) :: size !< Dimension sizes for the input data + type(axistype), dimension(4), optional, intent(inout) :: axes !< Axis types for the input data + real, optional, intent(inout) :: missing !< Missing value for the input data + + if (present(size)) then + size(1:4) = get_extern_field_size(field_id) + endif + + if (present(axes)) then + axes(1:4) = get_extern_field_axes(field_id) + endif + + if (present(missing)) then + missing = get_extern_field_missing(field_id) + endif + +end subroutine get_external_field_info + + +!> Read a scalar field based on model time. +subroutine time_interp_extern_0d(field_id, time, data_in, verbose) + integer, intent(in) :: field_id !< The integer index of the external field returned + !! from a previous call to init_external_field() + type(time_type), intent(in) :: time !< The target time for the data + real, intent(inout) :: data_in !< The interpolated value + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + + call time_interp_external(field_id, time, data_in, verbose=verbose) +end subroutine time_interp_extern_0d + + +!> Read a 2d field from an external based on model time, potentially including horizontal +!! interpolation and rotation of the data +subroutine time_interp_extern_2d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) + integer, intent(in) :: field_id !< The integer index of the external field returned + !! from a previous call to init_external_field() + type(time_type), intent(in) :: time !< The target time for the data + real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:), & + optional, intent(out) :: mask_out !< An array that is true where there is valid data + + call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + horz_interp=horz_interp, mask_out=mask_out) +end subroutine time_interp_extern_2d + + +!> Read a 3d field based on model time, and rotate to the model grid +subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) + integer, intent(in) :: field_id !< The integer index of the external field returned + !! from a previous call to init_external_field() + type(time_type), intent(in) :: time !< The target time for the data + real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:,:), & + optional, intent(out) :: mask_out !< An array that is true where there is valid data + + call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + horz_interp=horz_interp, mask_out=mask_out) +end subroutine time_interp_extern_3d + + +!> initialize an external field +integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & + threading, ierr, ignore_axis_atts ) + + character(len=*), intent(in) :: file !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the field in the file + integer, optional, intent(in) :: threading !< A flag specifying whether the root PE reads + !! the data and broadcasts it (SINGLE_FILE) or all + !! processors read (MULTIPLE, the default). + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(domain2d), optional, intent(in) :: domain !< A domain2d type that describes the decomposition + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(out) :: ierr !< Returns a non-zero error code in case of failure + logical, optional, intent(in) :: ignore_axis_atts !< If present and true, do not issue a + !! fatal error if the axis Cartesian attribute is + !! not set to a recognized value. + + if (present(MOM_Domain)) then + init_extern_field = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & + verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts) + else + init_extern_field = init_external_field(file, fieldname, domain=domain, & + verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts) + endif + +end function init_extern_field + +end module MOM_interp_infra diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 new file mode 100644 index 0000000000..4833c37e3a --- /dev/null +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -0,0 +1,1937 @@ +!> This module contains a thin inteface to mpp and fms I/O code +module MOM_io_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE +use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING, is_root_PE +use MOM_string_functions, only : lowercase + +use fms2_io_mod, only : fms2_open_file => open_file, check_if_open, fms2_close_file => close_file +use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, fms2_read_data => read_data +use fms2_io_mod, only : get_unlimited_dimension_name, get_num_dimensions, get_num_variables +use fms2_io_mod, only : get_variable_names, variable_exists, get_variable_size, get_variable_units +use fms2_io_mod, only : register_field, write_data, register_variable_attribute, register_global_attribute +use fms2_io_mod, only : variable_att_exists, get_variable_attribute, get_variable_num_dimensions +use fms2_io_mod, only : get_variable_dimension_names, is_dimension_registered, get_dimension_size +use fms2_io_mod, only : is_dimension_unlimited, register_axis, unlimited +use fms2_io_mod, only : get_global_io_domain_indices + +use fms_mod, only : write_version_number, open_namelist_file, check_nml_error +use fms_io_mod, only : file_exist, field_exist, field_size, read_data +use fms_io_mod, only : fms_io_exit, get_filename_appendix +use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_global_domain +use mpp_io_mod, only : mpp_open, mpp_close, mpp_flush +use mpp_io_mod, only : mpp_write_meta, mpp_write +use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist +use mpp_io_mod, only : mpp_get_axes, mpp_axistype=>axistype, mpp_get_axis_data +use mpp_io_mod, only : mpp_get_fields, mpp_fieldtype=>fieldtype +use mpp_io_mod, only : mpp_get_info, mpp_get_times +use mpp_io_mod, only : mpp_io_init +! These are encoding constants. +use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, WRITEONLY_FILE=>MPP_WRONLY +use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY +use mpp_io_mod, only : NETCDF_FILE=>MPP_NETCDF, ASCII_FILE=>MPP_ASCII +use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, SINGLE_FILE=>MPP_SINGLE +use iso_fortran_env, only : int64 + +implicit none ; private + +! These interfaces are actually implemented or have explicit interfaces in this file. +public :: open_file, open_ASCII_file, file_is_open, close_file, flush_file, file_exists +public :: get_file_info, get_file_fields, get_file_times, get_filename_suffix +public :: MOM_read_data, MOM_read_vector, write_metadata, write_field +public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum +public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version +! These types act as containers for information about files, fields and axes, respectively, +! and may also wrap opaque types from the underlying infrastructure. +public :: file_type, fieldtype, axistype +! These are encoding constant parmeters. +public :: ASCII_FILE, NETCDF_FILE, SINGLE_FILE, MULTIPLE +public :: APPEND_FILE, READONLY_FILE, OVERWRITE_FILE, WRITEONLY_FILE +public :: CENTER, CORNER, NORTH_FACE, EAST_FACE + +!> Indicate whether a file exists, perhaps with domain decomposition +interface file_exists + module procedure FMS_file_exists + module procedure MOM_file_exists +end interface + +!> Open a file (or fileset) for parallel or single-file I/O. +interface open_file + module procedure open_file_type, open_file_unit +end interface open_file + +!> Read a data field from a file +interface MOM_read_data + module procedure MOM_read_data_4d + module procedure MOM_read_data_3d + module procedure MOM_read_data_2d, MOM_read_data_2d_region + module procedure MOM_read_data_1d, MOM_read_data_1d_int + module procedure MOM_read_data_0d, MOM_read_data_0d_int +end interface + +!> Write a registered field to an output file +interface write_field + module procedure write_field_4d + module procedure write_field_3d + module procedure write_field_2d + module procedure write_field_1d + module procedure write_field_0d + module procedure MOM_write_axis +end interface write_field + +!> Read a pair of data fields representing the two components of a vector from a file +interface MOM_read_vector + module procedure MOM_read_vector_3d + module procedure MOM_read_vector_2d +end interface MOM_read_vector + +!> Write metadata about a variable or axis to a file and store it for later reuse +interface write_metadata + module procedure write_metadata_axis, write_metadata_field, write_metadata_global +end interface write_metadata + +!> Close a file (or fileset). If the file handle does not point to an open file, +!! close_file simply returns without doing anything. +interface close_file + module procedure close_file_type, close_file_unit +end interface close_file + +!> Ensure that the output stream associated with a file handle is fully sent to disk +interface flush_file + module procedure flush_file_type, flush_file_unit +end interface flush_file + +!> Type for holding a handle to an open file and related information +type :: file_type ; private + integer :: unit = -1 !< The framework identfier or netCDF unit number of an output file + type(FmsNetcdfDomainFile_t), pointer :: fileobj => NULL() !< A domain-decomposed + !! file object that is open for writing + character(len=:), allocatable :: filename !< The path to this file, if it is open + logical :: open_to_read = .false. !< If true, this file or fileset can be read + logical :: open_to_write = .false. !< If true, this file or fileset can be written to + integer :: num_times !< The number of time levels in this file + real :: file_time !< The time of the latest entry in the file. + logical :: FMS2_file !< If true, this file-type is to be used with FMS2 interfaces. +end type file_type + +!> This type is a container for information about a variable in a file. +type :: fieldtype ; private + character(len=256) :: name !< The name of this field in the files. + type(mpp_fieldtype) :: FT !< The FMS1 field-type that this type wraps + character(len=:), allocatable :: longname !< The long name for this field + character(len=:), allocatable :: units !< The units for this field + integer(kind=int64) :: chksum_read !< A checksum that has been read from a file + logical :: valid_chksum !< If true, this field has a valid checksum value. + logical :: FMS2_field !< If true, this field-type should be used with FMS2 interfaces. +end type fieldtype + +!> This type is a container for information about an axis in a file. +type :: axistype ; private + character(len=256) :: name !< The name of this axis in the files. + type(mpp_axistype) :: AT !< The FMS1 axis-type that this type wraps + real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. + logical :: domain_decomposed = .false. !< True if axis is domain-decomposed +end type axistype + +!> For now, these module-variables are hard-coded to exercise the new FMS2 interfaces. +logical :: FMS2_reads = .true. +logical :: FMS2_writes = .true. + +contains + +!> Reads the checksum value for a field that was recorded in a file, along with a flag indicating +!! whether the file contained a valid checksum for this field. +subroutine read_field_chksum(field, chksum, valid_chksum) + type(fieldtype), intent(in) :: field !< The field whose checksum attribute is to be read. + integer(kind=int64), intent(out) :: chksum !< The checksum for the field. + logical, intent(out) :: valid_chksum !< If true, chksum has been successfully read. + + chksum = -1 + valid_chksum = field%valid_chksum + if (valid_chksum) chksum = field%chksum_read + +end subroutine read_field_chksum + +!> Returns true if the named file or its domain-decomposed variant exists. +logical function MOM_file_exists(filename, MOM_Domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + +! This function uses the fms_io function file_exist to determine whether +! a named file (or its decomposed variant) exists. + + MOM_file_exists = file_exist(filename, MOM_Domain%mpp_domain) + +end function MOM_file_exists + +!> Returns true if the named file or its domain-decomposed variant exists. +logical function FMS_file_exists(filename, domain, no_domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + type(domain2d), optional, intent(in) :: domain !< The mpp domain2d that describes the decomposition + logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition +! This function uses the fms_io function file_exist to determine whether +! a named file (or its decomposed variant) exists. + + FMS_file_exists = file_exist(filename, domain, no_domain) + +end function FMS_file_exists + +!> indicates whether an I/O handle is attached to an open file +logical function file_is_open(IO_handle) + type(file_type), intent(in) :: IO_handle !< Handle to a file to inquire about + + file_is_open = ((IO_handle%unit >= 0) .or. associated(IO_handle%fileobj)) +end function file_is_open + +!> closes a file (or fileset). If the file handle does not point to an open file, +!! close_file_type simply returns without doing anything. +subroutine close_file_type(IO_handle) + type(file_type), intent(inout) :: IO_handle !< The I/O handle for the file to be closed + + if (associated(IO_handle%fileobj)) then + call fms2_close_file(IO_handle%fileobj) + deallocate(IO_handle%fileobj) + else + call mpp_close(IO_handle%unit) + endif + if (allocated(IO_handle%filename)) deallocate(IO_handle%filename) + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .false. + IO_handle%num_times = 0 ; IO_handle%file_time = 0.0 + IO_handle%FMS2_file = .false. +end subroutine close_file_type + +!> closes a file. If the unit does not point to an open file, +!! close_file_unit simply returns without doing anything. +subroutine close_file_unit(unit) + integer, intent(inout) :: unit !< The I/O unit for the file to be closed + + call mpp_close(unit) +end subroutine close_file_unit + +!> Ensure that the output stream associated with a file handle is fully sent to disk. +subroutine flush_file_type(IO_handle) + type(file_type), intent(in) :: IO_handle !< The I/O handle for the file to flush + + if (associated(IO_handle%fileobj)) then + ! There does not appear to be an fms2 flush call. + else + call mpp_flush(IO_handle%unit) + endif +end subroutine flush_file_type + +!> Ensure that the output stream associated with a unit is fully sent to disk. +subroutine flush_file_unit(unit) + integer, intent(in) :: unit !< The I/O unit for the file to flush + + call mpp_flush(unit) +end subroutine flush_file_unit + +!> Initialize the underlying I/O infrastructure +subroutine io_infra_init(maxunits) + integer, optional, intent(in) :: maxunits !< An optional maximum number of file + !! unit numbers that can be used. + call mpp_io_init(maxunit=maxunits) +end subroutine io_infra_init + +!> Gracefully close out and terminate the underlying I/O infrastructure +subroutine io_infra_end() + call fms_io_exit() +end subroutine io_infra_end + +!> Open a single namelist file that is potentially readable by all PEs. +function MOM_namelist_file(file) result(unit) + character(len=*), optional, intent(in) :: file !< The file to open, by default "input.nml". + integer :: unit !< The opened unit number of the namelist file + unit = open_namelist_file(file) +end function MOM_namelist_file + +!> Checks the iostat argument that is returned after reading a namelist variable and writes a +!! message if there is an error. +subroutine check_namelist_error(IOstat, nml_name) + integer, intent(in) :: IOstat !< An I/O status field from a namelist read call + character(len=*), intent(in) :: nml_name !< The name of the namelist + integer :: ierr + ierr = check_nml_error(IOstat, nml_name) +end subroutine check_namelist_error + +!> Write a file version number to the log file or other output file +subroutine write_version(version, tag, unit) + character(len=*), intent(in) :: version !< A string that contains the routine name and version + character(len=*), optional, intent(in) :: tag !< A tag name to add to the message + integer, optional, intent(in) :: unit !< An alternate unit number for output + + call write_version_number(version, tag, unit) +end subroutine write_version + +!> open_file opens a file for parallel or single-file I/O. +subroutine open_file_unit(unit, filename, action, form, threading, fileset, nohdrs, domain, MOM_domain) + integer, intent(out) :: unit !< The I/O unit for the opened file + character(len=*), intent(in) :: filename !< The name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + integer, optional, intent(in) :: form !< A flag indicating the format of a new file. The + !! default is ASCII_FILE, but NETCDF_FILE is also common. + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + logical, optional, intent(in) :: nohdrs !< If nohdrs is .TRUE., headers are not written to + !! ASCII files. The default is .false. + type(domain2d), optional, intent(in) :: domain !< A domain2d type that describes the decomposition + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + + if (present(MOM_Domain)) then + call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & + nohdrs=nohdrs, domain=MOM_Domain%mpp_domain) + else + call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & + nohdrs=nohdrs, domain=domain) + endif +end subroutine open_file_unit + +!> open_file opens a file for parallel or single-file I/O. +subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fileset) + type(file_type), intent(inout) :: IO_handle !< The handle for the opened file + character(len=*), intent(in) :: filename !< The path name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + !! The default is WRITE_ONLY. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj_read ! A handle to a domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: success ! If true, the file was opened successfully + integer :: file_mode ! An integer that encodes whether the file is to be opened for + ! reading, writing or appending + character(len=40) :: mode ! A character string that encodes whether the file is to be opened for + ! reading, writing or appending + character(len=:), allocatable :: filename_tmp ! A copy of filename with .nc appended if necessary. + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + integer :: index_nc + + if (IO_handle%open_to_write) then + call MOM_error(WARNING, "open_file_type called for file "//trim(filename)//& + " with an IO_handle that is already open to to write.") + return + endif + if (IO_handle%open_to_read) then + call MOM_error(FATAL, "open_file_type called for file "//trim(filename)//& + " with an IO_handle that is already open to to read.") + endif + + file_mode = WRITEONLY_FILE ; if (present(action)) file_mode = action + + if (FMS2_writes .and. present(MOM_Domain)) then + if (.not.associated(IO_handle%fileobj)) allocate (IO_handle%fileobj) + + ! The FMS1 interface automatically appends .nc if necessary, but FMS2 interface does not. + index_nc = index(trim(filename), ".nc") + if (index_nc > 0) then + filename_tmp = trim(filename) + else + filename_tmp = trim(filename)//".nc" + if (is_root_PE()) call MOM_error(WARNING, "Open_file is appending .nc to the filename "//trim(filename)) + endif + + if (file_mode == WRITEONLY_FILE) then ; mode = "write" + elseif (file_mode == APPEND_FILE) then ; mode = "append" + elseif (file_mode == OVERWRITE_FILE) then ; mode = "overwrite" + elseif (file_mode == READONLY_FILE) then ; mode = "read" + else + call MOM_error(FATAL, "open_file_type called with unrecognized action.") + endif + + IO_handle%num_times = 0 + IO_handle%file_time = 0.0 + if ((file_mode == APPEND_FILE) .and. file_exists(filename_tmp, MOM_Domain)) then + ! Determine the latest file time and number of records so far. + success = fms2_open_file(fileObj_read, trim(filename_tmp), "read", MOM_domain%mpp_domain) + call get_unlimited_dimension_name(fileObj_read, dim_unlim_name) + if (len_trim(dim_unlim_name) > 0) & + call get_dimension_size(fileObj_read, trim(dim_unlim_name), IO_handle%num_times) + if (IO_handle%num_times > 0) & + call fms2_read_data(fileObj_read, trim(dim_unlim_name), IO_handle%file_time, & + unlim_dim_level=IO_handle%num_times) + call fms2_close_file(fileObj_read) + endif + + success = fms2_open_file(IO_handle%fileobj, trim(filename_tmp), trim(mode), MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Unable to open file "//trim(filename_tmp)) + IO_handle%FMS2_file = .true. + elseif (present(MOM_Domain)) then + call mpp_open(IO_handle%unit, filename, action=file_mode, form=NETCDF_FILE, threading=threading, & + fileset=fileset, domain=MOM_Domain%mpp_domain) + IO_handle%FMS2_file = .false. + else + call mpp_open(IO_handle%unit, filename, action=file_mode, form=NETCDF_FILE, threading=threading, & + fileset=fileset) + IO_handle%FMS2_file = .false. + endif + IO_handle%filename = trim(filename) + + if (file_mode == READONLY_FILE) then + IO_handle%open_to_read = .true. ; IO_handle%open_to_write = .false. + else + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. + endif + +end subroutine open_file_type + +!> open_file opens an ascii file for parallel or single-file I/O using Fortran read and write calls. +subroutine open_ASCII_file(unit, file, action, threading, fileset) + integer, intent(out) :: unit !< The I/O unit for the opened file + character(len=*), intent(in) :: file !< The name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + + call mpp_open(unit, file, action=action, form=ASCII_FILE, threading=threading, fileset=fileset, & + nohdrs=.true.) + +end subroutine open_ASCII_file + + +!> Provide a string to append to filenames, to differentiate ensemble members, for example. +subroutine get_filename_suffix(suffix) + character(len=*), intent(out) :: suffix !< A string to append to filenames + + call get_filename_appendix(suffix) +end subroutine get_filename_suffix + + +!> Get information about the number of dimensions, variables and time levels +!! in the file associated with an open file unit +subroutine get_file_info(IO_handle, ndim, nvar, ntime) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim !< The number of dimensions in the file + integer, optional, intent(out) :: nvar !< The number of variables in the file + integer, optional, intent(out) :: ntime !< The number of time levels in the file + + ! Local variables + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + integer :: ndims, nvars, natts, ntimes + + if (IO_handle%FMS2_file) then + if (present(ndim)) ndim = get_num_dimensions(IO_handle%fileobj) + if (present(nvar)) nvar = get_num_variables(IO_handle%fileobj) + if (present(ntime)) then + ntime = 0 + call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) + if (len_trim(dim_unlim_name) > 0) & + call get_dimension_size(IO_handle%fileobj, trim(dim_unlim_name), ntime) + endif + else + call mpp_get_info(IO_handle%unit, ndims, nvars, natts, ntimes ) + + if (present(ndim)) ndim = ndims + if (present(nvar)) nvar = nvars + if (present(ntime)) ntime = ntimes + endif + +end subroutine get_file_info + + +!> Get the times of records from a file +subroutine get_file_times(IO_handle, time_values, ntime) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + real, allocatable, dimension(:), intent(inout) :: time_values !< The real times for the records in file. + integer, optional, intent(out) :: ntime !< The number of time levels in the file + + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + integer :: ntimes ! The number of time levels in the file + + !### Modify this routine to optionally convert to time_type, using information about the dimensions? + + if (allocated(time_values)) deallocate(time_values) + call get_file_info(IO_handle, ntime=ntimes) + if (present(ntime)) ntime = ntimes + if (ntimes > 0) then + allocate(time_values(ntimes)) + if (IO_handle%FMS2_file) then + call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) + call fms2_read_data(IO_handle%fileobj, trim(dim_unlim_name), time_values) + else + call mpp_get_times(IO_handle%unit, time_values) + endif + endif +end subroutine get_file_times + +!> Set up the field information (e.g., names and metadata) for all of the variables in a file. The +!! argument fields must be allocated with a size that matches the number of variables in a file. +subroutine get_file_fields(IO_handle, fields) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + type(fieldtype), dimension(:), intent(inout) :: fields !< Field-type descriptions of all of + !! the variables in a file. + type(mpp_fieldtype), dimension(size(fields)) :: mpp_fields ! Fieldtype structures for the variables + character(len=256), dimension(size(fields)) :: var_names ! The names of all variables + character(len=256) :: units ! The units of a variable as recorded in the file + character(len=2048) :: longname ! The long-name of a variable as recorded in the file + character(len=64) :: checksum_char ! The hexadecimal checksum read from the file + integer(kind=int64), dimension(3) :: checksum_file ! The checksums for a variable in the file + integer :: nvar ! The number of variables in the file + integer :: i + + nvar = size(fields) + ! Local variables + if (IO_handle%FMS2_file) then + call get_variable_names(IO_handle%fileobj, var_names) + do i=1,nvar + fields(i)%name = trim(var_names(i)) + longname = "" + call get_variable_attribute(IO_handle%fileobj, var_names(i), 'long_name', longname) + fields(i)%longname = trim(longname) + units = "" + call get_variable_attribute(IO_handle%fileobj, var_names(i), 'units', units) + fields(i)%units = trim(units) + + fields(i)%valid_chksum = variable_att_exists(IO_handle%fileobj, var_names(i), "checksum") + if (fields(i)%valid_chksum) then + call get_variable_attribute(IO_handle%fileobj, var_names(i), 'checksum', checksum_char) + ! If there are problems, there might need to be code added to handle commas. + read (checksum_char(1:16), '(Z16)') fields(i)%chksum_read + endif + enddo + else + call mpp_get_fields(IO_handle%unit, mpp_fields) + do i=1,nvar + fields(i)%FT = mpp_fields(i) + call mpp_get_atts(fields(i)%FT, name=fields(i)%name, units=units, longname=longname, & + checksum=checksum_file) + fields(i)%longname = trim(longname) + fields(i)%units = trim(units) + fields(i)%valid_chksum = mpp_attribute_exist(fields(i)%FT, "checksum") + if (fields(i)%valid_chksum) fields(i)%chksum_read = checksum_file(1) + enddo + endif + +end subroutine get_file_fields + +!> Extract information from a field type, as stored or as found in a file +subroutine get_field_atts(field, name, units, longname, checksum) + type(fieldtype), intent(in) :: field !< The field to extract information from + character(len=*), optional, intent(out) :: name !< The variable name + character(len=*), optional, intent(out) :: units !< The units of the variable + character(len=*), optional, intent(out) :: longname !< The long name of the variable + integer(kind=int64), dimension(:), & + optional, intent(out) :: checksum !< The checksums of the variable in a file + + if (present(name)) name = trim(field%name) + if (present(units)) units = trim(field%units) + if (present(longname)) longname = trim(field%longname) + if (present(checksum)) checksum = field%chksum_read + +end subroutine get_field_atts + +!> Field_exists returns true if the field indicated by field_name is present in the +!! file file_name. If file_name does not exist, it returns false. +function field_exists(filename, field_name, domain, no_domain, MOM_domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + character(len=*), intent(in) :: field_name !< The name of the field being sought + type(domain2d), target, optional, intent(in) :: domain !< A domain2d type that describes the decomposition + logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + logical :: field_exists !< True if filename exists and field_name is in filename + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileObj_dd ! A handle to a domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + type(FmsNetcdfFile_t) :: fileObj_simple ! A handle to a non-domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: success ! If true, the file was opened successfully + logical :: domainless ! If true, this file does not use a domain-decomposed file. + + domainless = .not.(present(MOM_domain) .or. present(domain)) + if (present(no_domain)) then + if (domainless .and. .not.no_domain) call MOM_error(FATAL, & + "field_exists: When no_domain is present and false, a domain must be supplied in query about "//& + trim(field_name)//" in file "//trim(filename)) + domainless = no_domain + endif + + if (FMS2_reads) then + field_exists = .false. + if (file_exists(filename)) then + if (domainless) then + success = fms2_open_file(fileObj_simple, trim(filename), "read") + if (success) then + field_exists = variable_exists(fileObj_simple, field_name) + call fms2_close_file(fileObj_simple) + endif + else + if (present(MOM_domain)) then + success = fms2_open_file(fileObj_dd, trim(filename), "read", MOM_domain%mpp_domain) + else + success = fms2_open_file(fileObj_dd, trim(filename), "read", domain) + endif + if (success) then + field_exists = variable_exists(fileobj_dd, field_name) + call fms2_close_file(fileObj_dd) + endif + endif + endif + elseif (present(MOM_domain)) then + field_exists = field_exist(filename, field_name, domain=MOM_domain%mpp_domain, no_domain=no_domain) + else + field_exists = field_exist(filename, field_name, domain=domain, no_domain=no_domain) + endif + +end function field_exists + +!> Given filename and fieldname, this subroutine returns the size of the field in the file +subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the variable whose sizes are returned + integer, dimension(:), intent(inout) :: sizes !< The sizes of the variable in each dimension + logical, optional, intent(out) :: field_found !< This indicates whether the field was found in + !! the input file. Without this argument, there + !! is a fatal error if the field is not found. + logical, optional, intent(in) :: no_domain !< If present and true, do not check for file + !! names with an appended tile number + + ! Local variables + type(FmsNetcdfFile_t) :: fileobj_read ! A handle to a non-domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: success ! If true, the file was opened successfully + logical :: field_exists ! True if filename exists and field_name is in filename + integer :: i, ndims + + if (FMS2_reads) then + field_exists = .false. + if (file_exists(filename)) then + success = fms2_open_file(fileObj_read, trim(filename), "read") + if (success) then + field_exists = variable_exists(fileobj_read, fieldname) + if (field_exists) then + ndims = get_variable_num_dimensions(fileobj_read, fieldname) + if (ndims > size(sizes)) call MOM_error(FATAL, & + "get_field_size called with too few sizes for "//trim(fieldname)//" in "//trim(filename)) + call get_variable_size(fileobj_read, fieldname, sizes(1:ndims)) + do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo + endif + endif + endif + if (present(field_found)) field_found = field_exists + else + call field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) + endif + +end subroutine get_field_size + +!> Extracts and returns the axis data stored in an axistype. +subroutine get_axis_data( axis, dat ) + type(axistype), intent(in) :: axis !< An axis type + real, dimension(:), intent(out) :: dat !< The data in the axis variable + + integer :: i + + ! This routine might not be needed for MOM6. + if (allocated(axis%ax_data)) then + if (size(axis%ax_data) > size(dat)) call MOM_error(FATAL, & + "get_axis_data called with too small of an output data array for "//trim(axis%name)) + do i=1,size(axis%ax_data) ; dat(i) = axis%ax_data(i) ; enddo + elseif (.not.FMS2_writes) then + call mpp_get_axis_data( axis%AT, dat ) + endif + +end subroutine get_axis_data + +!> This routine uses the fms_io subroutine read_data to read a scalar named +!! "fieldname" from a single or domain-decomposed file "filename". +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain) .and. FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj_DD, fieldname, "MOM_read_data_0d: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj_DD, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj_DD, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + elseif (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "MOM_read_data_0d: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) + else + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + data = scale*data + endif ; endif + +end subroutine MOM_read_data_0d + +!> This routine uses the fms_io subroutine read_data to read a 1-D data field named +!! "fieldname" from a single or domain-decomposed file "filename". +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before they are returned. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain) .and. FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj_DD, fieldname, "MOM_read_data_1d: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj_DD, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj_DD, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + elseif (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "MOM_read_data_1d: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) + else + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + data(:) = scale*data(:) + endif ; endif + +end subroutine MOM_read_data_1d + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 2-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened + + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "MOM_read_data_2d: ", filename, & + var_to_read, has_time_dim, timelevel, position) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else ! Read the variable using the FMS-1 interface. + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif + +end subroutine MOM_read_data_2d + +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 2-D data field named "fieldname" from file "filename". +subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 4 + !! dimensions. For this 2-d read, the 3rd + !! and 4th values are always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 2-d read, the 3rd + !! and 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain) .and. FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj_DD, fieldname, "MOM_read_data_2d_region: ", & + filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj_DD, var_to_read, data, corner=start(1:2), edge_lengths=nread(1:2)) + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + elseif (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "MOM_read_data_2d_region: ", filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj, var_to_read, data, corner=start(1:2), edge_lengths=nread(1:2)) + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. + call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & + no_domain=no_domain) + else + call read_data(filename, fieldname, data, start, nread, no_domain=no_domain) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:) = scale*data(:,:) + endif + endif ; endif + +end subroutine MOM_read_data_2d_region + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 3-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened + + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "MOM_read_data_3d: ", filename, & + var_to_read, has_time_dim, timelevel, position) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else ! Read the variable using the FMS-1 interface. + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif + +end subroutine MOM_read_data_3d + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 4-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:,:), intent(inout) :: data !< The 4-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "MOM_read_data_4d: ", filename, & + var_to_read, has_time_dim, timelevel, position) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else ! Read the variable using the FMS-1 interface. + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif + +end subroutine MOM_read_data_4d + +!> This routine uses the fms_io subroutine read_data to read a scalar integer +!! data field named "fieldname" from file "filename". +subroutine MOM_read_data_0d_int(filename, fieldname, data, timelevel) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + integer, intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! If true, the file was opened successfully + + ! This routine might not be needed for MOM6. + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "MOM_read_data_0d_int: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + endif + +end subroutine MOM_read_data_0d_int + +!> This routine uses the fms_io subroutine read_data to read a 1-D integer +!! data field named "fieldname" from file "filename". +subroutine MOM_read_data_1d_int(filename, fieldname, data, timelevel) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + integer, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! If true, the file was opened successfully + + ! This routine might not be needed for MOM6. + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "MOM_read_data_1d_int: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + endif + +end subroutine MOM_read_data_1d_int + + +!> This routine uses the fms_io subroutine read_data to read a pair of distributed +!! 2-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for +!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. +subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file + character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file + real, dimension(:,:), intent(inout) :: u_data !< The 2 dimensional array into which the + !! u-component of the data should be read + real, dimension(:,:), intent(inout) :: v_data !< The 2 dimensional array into which the + !! v-component of the data should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variables have an unlimited time axis. + character(len=96) :: u_var, v_var ! Name of u and v variables to read from the netcdf file + logical :: success ! True if the file was successfully opened + integer :: u_pos, v_pos ! Flags indicating the positions of the u- and v- components. + + u_pos = EAST_FACE ; v_pos = NORTH_FACE + if (present(stagger)) then + if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE + elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER + elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif + endif + + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. + call prepare_to_read_var(fileobj, u_fieldname, "MOM_read_vector_2d: ", filename, & + u_var, has_time_dim, timelevel, position=u_pos) + call prepare_to_read_var(fileobj, v_fieldname, "MOM_read_vector_2d: ", filename, & + v_var, has_time_dim, timelevel, position=v_pos) + + ! Read the u-data and v-data. There would already been an error message for one + ! of the variables if they are inconsistent in having an unlimited dimension. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) + call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, u_var, u_data) + call fms2_read_data(fileobj, v_var, v_data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else ! Read the variable using the FMS-1 interface. + call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=u_pos) + call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=v_pos) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) + endif ; endif + +end subroutine MOM_read_vector_2d + +!> This routine uses the fms_io subroutine read_data to read a pair of distributed +!! 3-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for +!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. +subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file + character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file + real, dimension(:,:,:), intent(inout) :: u_data !< The 3 dimensional array into which the + !! u-component of the data should be read + real, dimension(:,:,:), intent(inout) :: v_data !< The 3 dimensional array into which the + !! v-component of the data should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read. + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variables have an unlimited time axis. + character(len=96) :: u_var, v_var ! Name of u and v variables to read from the netcdf file + logical :: success ! True if the file was successfully opened + integer :: u_pos, v_pos ! Flags indicating the positions of the u- and v- components. + + u_pos = EAST_FACE ; v_pos = NORTH_FACE + if (present(stagger)) then + if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE + elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER + elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif + endif + + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. + call prepare_to_read_var(fileobj, u_fieldname, "MOM_read_vector_3d: ", filename, & + u_var, has_time_dim, timelevel, position=u_pos) + call prepare_to_read_var(fileobj, v_fieldname, "MOM_read_vector_3d: ", filename, & + v_var, has_time_dim, timelevel, position=v_pos) + + ! Read the u-data and v-data, dangerously assuming either both or neither have time dimensions. + ! There would already been an error message for one of the variables if they are inconsistent. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) + call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, u_var, u_data) + call fms2_read_data(fileobj, v_var, v_data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else ! Read the variable using the FMS-1 interface. + call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=u_pos) + call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=v_pos) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) + endif ; endif + +end subroutine MOM_read_vector_3d + + +!> Find the case-sensitive name of the variable in a netCDF file with a case-insensitive name match. +!! Optionally also determine whether this variable has an unlimited time dimension. +subroutine find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read, has_time_dim, timelevel) + type(FmsNetcdfFile_t), intent(inout) :: fileobj !< An FMS2 handle to an open NetCDF file + character(len=*), intent(in) :: fieldname !< The variable name to seek in the file + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(out) :: var_to_read !< The variable name to read from the file + logical, optional, intent(out) :: has_time_dim !< Indicates whether fieldname has a time dimension + integer, optional, intent(in) :: timelevel !< A time level to read + + ! Local variables + logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? + character(len=256), allocatable, dimension(:) :: var_names ! The names of all the variables in the netCDF file + character(len=256), allocatable :: dim_names(:) ! The names of a variable's dimensions + integer :: nvars ! The number of variables in the file + integer :: dim_unlim_size ! The current size of the unlimited (time) dimension in the file. + integer :: num_var_dims ! The number of dimensions a variable has in the file. + integer :: time_dim ! The position of the unlimited (time) dimension for a variable, or -1 + ! if it has no unlimited dimension. + integer :: i + + ! Open the file if necessary + if (.not.check_if_open(fileobj)) & + call MOM_error(FATAL, trim(err_header)//trim(filename)//" was not open in call to find_varname_in_file.") + + ! Search for the variable in the file, looking for the case-sensitive name first. + if (variable_exists(fileobj, trim(fieldname))) then + var_to_read = trim(fieldname) + else ! Look for case-insensitive variable name matches. + nvars = get_num_variables(fileobj) + if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) + allocate(var_names(nvars)) + call get_variable_names(fileobj, var_names) + + ! search for the variable in the file + variable_found = .false. + do i=1,nvars + if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then + variable_found = .true. + var_to_read = trim(var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) + deallocate(var_names) + endif + + ! FMS2 can not handle a timelevel argument if the variable does not have one in the file, + ! so some error checking and logic are required. + if (present(has_time_dim) .or. present(timelevel)) then + time_dim = -1 + + num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) + allocate(dim_names(num_var_dims)) ; dim_names(:) = "" + call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) + + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + time_dim = i + if (present(timelevel)) then + call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) + if ((timelevel > dim_unlim_size) .and. is_root_PE()) call MOM_error(FATAL, & + trim(err_header)//"Attempting to read a time level of "//trim(var_to_read)//& + " that exceeds the size of the time dimension in "//trim(filename)) + endif + exit + endif + enddo + deallocate(dim_names) + + if (present(timelevel) .and. (time_dim < 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& + trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) + if ((.not.present(timelevel)) .and. (time_dim > 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"The variable "//trim(var_to_read)//& + " has an unlimited dimension in "//trim(filename)//" but no time level is specified.") + if (present(has_time_dim)) has_time_dim = (time_dim > 0) + endif + +end subroutine find_varname_in_file + + +!> Find the case-insensitive name match with a variable in an open domain-decomposed file-set, +!! prepare FMS2 to read this variable, and return some information needed to call fms2_read_data +!! correctly for this variable and file. +subroutine prepare_to_read_var(fileobj, fieldname, err_header, filename, var_to_read, & + has_time_dim, timelevel, position) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< An FMS2 handle to an open domain-decomposed file + character(len=*), intent(in) :: fieldname !< The variable name to seek in the file + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(out) :: var_to_read !< The variable name to read from the file + logical, optional, intent(out) :: has_time_dim !< Indicates whether fieldname has a time dimension + integer, optional, intent(in) :: timelevel !< A time level to read + integer, optional, intent(in) :: position !< A flag indicating where this variable is discretized + + ! Local variables + logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? + character(len=256), allocatable, dimension(:) :: var_names ! The names of all the variables in the netCDF file + character(len=256), allocatable :: dim_names(:) ! The names of a variable's dimensions + integer :: nvars ! The number of variables in the file. + integer :: dim_unlim_size ! The current size of the unlimited (time) dimension in the file. + integer :: num_var_dims ! The number of dimensions a variable has in the file. + integer :: time_dim ! The position of the unlimited (time) dimension for a variable, or -1 + ! if it has no unlimited dimension. + integer :: i + + ! Open the file if necessary + if (.not.check_if_open(fileobj)) & + call MOM_error(FATAL, trim(err_header)//trim(filename)//" was not open in call to prepare_to_read_var.") + + ! Search for the variable in the file, looking for the case-sensitive name first. + if (variable_exists(fileobj, trim(fieldname))) then + var_to_read = trim(fieldname) + else ! Look for case-insensitive variable name matches. + nvars = get_num_variables(fileobj) + if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) + allocate(var_names(nvars)) + call get_variable_names(fileobj, var_names) + + variable_found = .false. + do i=1,nvars + if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then + variable_found = .true. + var_to_read = trim(var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) + deallocate(var_names) + endif + + ! FMS2 can not handle a timelevel argument if the variable does not have one in the file, + ! so some error checking and logic are required. + if (present(has_time_dim) .or. present(timelevel)) then + time_dim = -1 + + num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) + allocate(dim_names(num_var_dims)) ; dim_names(:) = "" + call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) + + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + time_dim = i + if (present(timelevel)) then + call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) + if ((timelevel > dim_unlim_size) .and. is_root_PE()) call MOM_error(FATAL, & + trim(err_header)//"Attempting to read a time level of "//trim(var_to_read)//& + " that exceeds the size of the time dimension in "//trim(filename)) + endif + exit + endif + enddo + deallocate(dim_names) + + if (present(timelevel) .and. (time_dim < 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& + trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) + if ((.not.present(timelevel)) .and. (time_dim > 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"The variable "//trim(var_to_read)//& + " has an unlimited dimension in "//trim(filename)//" but no time level is specified.") + if (present(has_time_dim)) has_time_dim = (time_dim > 0) + endif + + ! Registering the variable axes essentially just specifies the discrete position of this variable. + call MOM_register_variable_axes(fileobj, var_to_read, filename, position) + +end subroutine prepare_to_read_var + +!> register axes associated with a variable from a domain-decomposed netCDF file +subroutine MOM_register_variable_axes(fileObj, variableName, filename, position) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileObj !< Handle to an open FMS2 netCDF file object + character(len=*), intent(in) :: variableName !< name of the variable + character(len=*), intent(in) :: filename !< The name of the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is discretized + + ! Local variables + character(len=256), allocatable, dimension(:) :: dim_names ! variable dimension names + integer, allocatable, dimension(:) :: dimSizes ! variable dimension sizes + logical, allocatable, dimension(:) :: is_x ! Is this a (likely domain-decomposed) x-axis + logical, allocatable, dimension(:) :: is_y ! Is this a (likely domain-decomposed) y-axis + logical, allocatable, dimension(:) :: is_t ! Is this a time axis or another unlimited axis + integer :: ndims ! number of dimensions + integer :: xPos, yPos ! Discrete positions for x and y axes. Default is CENTER + integer :: i + + xPos = CENTER ; yPos = CENTER + if (present(position)) then + if ((position == CORNER) .or. (position == EAST_FACE)) xPos = EAST_FACE + if ((position == CORNER) .or. (position == NORTH_FACE)) yPos = NORTH_FACE + endif + + ! get variable dimension names and lengths + ndims = get_variable_num_dimensions(fileObj, trim(variableName)) + allocate(dimSizes(ndims)) + allocate(dim_names(ndims)) + allocate(is_x(ndims)) ; is_x(:) = .false. + allocate(is_y(ndims)) ; is_y(:) = .false. + allocate(is_t(ndims)) ; is_t(:) = .false. + call get_variable_size(fileObj, trim(variableName), dimSizes) + call get_variable_dimension_names(fileObj, trim(variableName), dim_names) + call categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) + + ! register the axes + do i=1,ndims + if ( .not.is_dimension_registered(fileobj, trim(dim_names(i))) ) then + if (is_x(i)) then + call register_axis(fileObj, trim(dim_names(i)), "x", domain_position=xPos) + elseif (is_y(i)) then + call register_axis(fileObj, trim(dim_names(i)), "y", domain_position=yPos) + else + call register_axis(fileObj, trim(dim_names(i)), dimSizes(i)) + endif + endif + enddo + + deallocate(dimSizes, dim_names, is_x, is_y, is_t) +end subroutine MOM_register_variable_axes + +!> Determine whether a variable's axes are associated with x-, y- or time-dimensions. Other +!! unlimited dimensions are also labeled as time axes for these purposes. +subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) + type(FmsNetcdfDomainFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object + character(len=*), intent(in) :: filename !< The name of the file to read + integer, intent(in) :: ndims !< The number of dimensions associated with a variable + character(len=*), dimension(ndims), intent(in) :: dim_names !< Names of the dimensions associated with a variable + logical, dimension(ndims), intent(out) :: is_x !< Indicates if each dimension a (likely decomposed) x-axis + logical, dimension(ndims), intent(out) :: is_y !< Indicates if each dimension a (likely decomposed) y-axis + logical, dimension(ndims), intent(out) :: is_t !< Indicates if each dimension unlimited (usually time) axis + + ! Local variables + character(len=128) :: cartesian ! A flag indicating a Cartesian direction - usually a single character. + character(len=512) :: dim_list ! A concatenated list of dimension names. + character(len=128) :: units ! units corresponding to a specific variable dimension + logical :: x_found, y_found ! Indicate whether an x- or y- dimension have been found. + integer :: i + + x_found = .false. ; y_found = .false. + is_x(:) = .false. ; is_y(:) = .false. + do i=1,ndims + is_t(i) = is_dimension_unlimited(fileObj, trim(dim_names(i))) + ! First look for indicative variable attributes + if (.not.is_t(i)) then + if (variable_exists(fileobj, trim(dim_names(i)))) then + if (variable_att_exists(fileobj, trim(dim_names(i)), "cartesian_axis")) then + call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian) + cartesian = adjustl(cartesian) + if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. + if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. + if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. + endif + endif + endif + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + enddo + + if (.not.(x_found .and. y_found)) then + ! Next look for hints from axis names for uncharacterized axes + do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then + call categorize_axis_from_name(dim_names(i), is_x(i), is_y(i)) + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + endif ; enddo + endif + + if (.not.(x_found .and. y_found)) then + ! Look for hints from CF-compliant axis units for uncharacterized axes + do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then + call get_variable_units(fileobj, trim(dim_names(i)), units) + call categorize_axis_from_units(units, is_x(i), is_y(i)) + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + endif ; enddo + endif + + if (.not.(x_found .and. y_found) .and. ((ndims>2) .or. ((ndims==2) .and. .not.is_t(ndims)))) then + ! This is a case where one would expect to find x-and y-dimensions, but none have been found. + if (is_root_pe()) then + dim_list = trim(dim_names(1))//", "//trim(dim_names(2)) + do i=3,ndims ; dim_list = trim(dim_list)//", "//trim(dim_names(i)) ; enddo + call MOM_error(WARNING, "categorize_axes: Failed to identify x- and y- axes in the axis list ("//& + trim(dim_list)//") of a variable being read from "//trim(filename)) + endif + endif + +end subroutine categorize_axes + +!> Determine whether an axis is associated with the x- or y-directions based on a comparison of +!! its units with CF-compliant variants of latitude or longitude units. +subroutine categorize_axis_from_units(unit_string, is_x, is_y) + character(len=*), intent(in) :: unit_string !< string of units + logical, intent(out) :: is_x !< Indicates if the axis units are associated with an x-direction axis + logical, intent(out) :: is_y !< Indicates if the axis units are associated with an y-direction axis + + is_x = .false. ; is_y = .false. + select case (lowercase(trim(unit_string))) + case ("degrees_north"); is_y = .true. + case ("degree_north") ; is_y = .true. + case ("degrees_n") ; is_y = .true. + case ("degree_n") ; is_y = .true. + case ("degreen") ; is_y = .true. + case ("degreesn") ; is_y = .true. + case ("degrees_east") ; is_x = .true. + case ("degree_east") ; is_x = .true. + case ("degreese") ; is_x = .true. + case ("degreee") ; is_x = .true. + case ("degree_e") ; is_x = .true. + case ("degrees_e") ; is_x = .true. + case default ; is_x = .false. ; is_y = .false. + end select + +end subroutine categorize_axis_from_units + +!> Tries to determine whether the axis name is commonly associated with an x- or y- axis. This +!! approach is fragile and unreliable, but it a backup to reading a CARTESIAN file attribute. +subroutine categorize_axis_from_name(dimname, is_x, is_y) + character(len=*), intent(in) :: dimname !< A dimension name + logical, intent(out) :: is_x !< Indicates if the axis name is associated with an x-direction axis + logical, intent(out) :: is_y !< Indicates if the axis name is associated with an y-direction axis + + is_x = .false. ; is_y = .false. + select case(trim(lowercase(dimname))) + case ("grid_x_t") ; is_x = .true. + case ("nx") ; is_x = .true. + case ("nxp") ; is_x = .true. + case ("longitude") ; is_x = .true. + case ("long") ; is_x = .true. + case ("lon") ; is_x = .true. + case ("lonh") ; is_x = .true. + case ("lonq") ; is_x = .true. + case ("xh") ; is_x = .true. + case ("xq") ; is_x = .true. + case ("i") ; is_x = .true. + + case ("grid_y_t") ; is_y = .true. + case ("ny") ; is_y = .true. + case ("nyp") ; is_y = .true. + case ("latitude") ; is_y = .true. + case ("lat") ; is_y = .true. + case ("lath") ; is_y = .true. + case ("latq") ; is_y = .true. + case ("yh") ; is_y = .true. + case ("yq") ; is_y = .true. + case ("j") ; is_y = .true. + + case default ; is_x = .false. ; is_y = .false. + end select + +end subroutine categorize_axis_from_name + + +!> Write a 4d field to an output file. +subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + + ! Local variables + integer :: time_index + + if (IO_handle%FMS2_file .and. present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + elseif (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(field_md%name), field) + else + call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) + endif +end subroutine write_field_4d + +!> Write a 3d field to an output file. +subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + ! Local variables + integer :: time_index + + if (IO_handle%FMS2_file .and. present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + elseif (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(field_md%name), field) + else + call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) + endif +end subroutine write_field_3d + +!> Write a 2d field to an output file. +subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + ! Local variables + integer :: time_index + + if (IO_handle%FMS2_file .and. present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + elseif (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(field_md%name), field) + else + call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) + endif +end subroutine write_field_2d + +!> Write a 1d field to an output file. +subroutine write_field_1d(IO_handle, field_md, field, tstamp) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, dimension(:), intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + + ! Local variables + integer :: time_index + + if (IO_handle%FMS2_file .and. present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + elseif (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(field_md%name), field) + else + call mpp_write(IO_handle%unit, field_md%FT, field, tstamp=tstamp) + endif +end subroutine write_field_1d + +!> Write a 0d field to an output file. +subroutine write_field_0d(IO_handle, field_md, field, tstamp) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + + ! Local variables + integer :: time_index + + if (IO_handle%FMS2_file .and. present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + elseif (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(field_md%name), field) + else + call mpp_write(IO_handle%unit, field_md%FT, field, tstamp=tstamp) + endif +end subroutine write_field_0d + +!> Returns the integer time index for a write in this file, also writing the time variable to +!! the file if this time is later than what is already in the file. +integer function write_time_if_later(IO_handle, field_time) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + real, intent(in) :: field_time !< Model time of this field + + ! Local variables + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + + if ((field_time > IO_handle%file_time) .or. (IO_handle%num_times == 0)) then + IO_handle%file_time = field_time + IO_handle%num_times = IO_handle%num_times + 1 + if (IO_handle%FMS2_file) then + call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) + call write_data(IO_handle%fileobj, trim(dim_unlim_name), (/field_time/), & + corner=(/IO_handle%num_times/), edge_lengths=(/1/)) + endif + endif + + write_time_if_later = IO_handle%num_times +end function write_time_if_later + +!> Write the data for an axis +subroutine MOM_write_axis(IO_handle, axis) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(axistype), intent(in) :: axis !< An axis type variable with information to write + + integer :: is, ie + + if (IO_handle%FMS2_file) then + if (axis%domain_decomposed) then + ! FMS2 does not domain-decompose 1d arrays, so we explicitly slice it + call get_global_io_domain_indices(IO_handle%fileobj, trim(axis%name), is, ie) + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data(is:ie)) + else + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data) + endif + else + call mpp_write(IO_handle%unit, axis%AT) + endif + +end subroutine MOM_write_axis + +!> Store information about an axis in a previously defined axistype and write this +!! information to the file indicated by unit. +subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, data, & + edge_axis, calendar) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(axistype), intent(inout) :: axis !< The axistype where this information is stored. + character(len=*), intent(in) :: name !< The name in the file of this axis + character(len=*), intent(in) :: units !< The units of this axis + character(len=*), intent(in) :: longname !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian !< A variable indicating which direction + !! this axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense !< This is 1 for axes whose values increase upward, or + !! -1 if they increase downward. + type(domain1D), optional, intent(in) :: domain !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar !< The name of the calendar used with a time axis + + character(len=:), allocatable :: cart ! A left-adjusted and trimmed copy of cartesian + logical :: is_x, is_y, is_t ! If true, this is a domain-decomposed axis in one of the directions. + integer :: position ! A flag indicating the axis staggering position. + integer :: i, isc, iec, global_size + + if (IO_handle%FMS2_file) then + if (is_dimension_registered(IO_handle%fileobj, trim(name))) then + call MOM_error(FATAL, "write_metadata_axis was called more than once for axis "//trim(name)//& + " in file "//trim(IO_handle%filename)) + return + endif + endif + + axis%name = trim(name) + if (present(data) .and. allocated(axis%ax_data)) call MOM_error(FATAL, & + "Data is already allocated in a call to write_metadata_axis for axis "//& + trim(name)//" in file "//trim(IO_handle%filename)) + + if (IO_handle%FMS2_file) then + is_x = .false. ; is_y = .false. ; is_t = .false. + position = CENTER + if (present(cartesian)) then + cart = trim(adjustl(cartesian)) + if ((index(cart, "X") == 1) .or. (index(cart, "x") == 1)) is_x = .true. + if ((index(cart, "Y") == 1) .or. (index(cart, "y") == 1)) is_y = .true. + if ((index(cart, "T") == 1) .or. (index(cart, "t") == 1)) is_t = .true. + endif + + ! For now, we assume that all horizontal axes are domain-decomposed. + if (is_x .or. is_y) & + axis%domain_decomposed = .true. + + if (is_x) then + if (present(edge_axis)) then ; if (edge_axis) position = EAST_FACE ; endif + call register_axis(IO_handle%fileobj, trim(name), 'x', domain_position=position) + elseif (is_y) then + if (present(edge_axis)) then ; if (edge_axis) position = NORTH_FACE ; endif + call register_axis(IO_handle%fileobj, trim(name), 'y', domain_position=position) + elseif (is_t .and. .not.present(data)) then + ! This is the unlimited (time) dimension. + call register_axis(IO_handle%fileobj, trim(name), unlimited) + else + if (.not.present(data)) call MOM_error(FATAL,"MOM_io:register_diagnostic_axis: "//& + "An axis_length argument is required to register the axis "//trim(name)) + call register_axis(IO_handle%fileobj, trim(name), size(data)) + endif + + if (present(data)) then + ! With FMS2, the data for the axis labels has to match the computational domain on this PE. + if (present(domain)) then + ! The commented-out code on the next ~11 lines runs but there is missing data in the output file + ! call mpp_get_compute_domain(domain, isc, iec) + ! call mpp_get_global_domain(domain, size=global_size) + ! if (size(data) == global_size) then + ! allocate(axis%ax_data(iec+1-isc)) ; axis%ax_data(:) = data(isc:iec) + ! ! A simpler set of labels: do i=1,iec-isc ; axis%ax_data(i) = real(isc + i) - 1.0 ; enddo + ! elseif (size(data) == global_size+1) then + ! ! This is an edge axis. Note the effective SW indexing convention here. + ! allocate(axis%ax_data(iec+2-isc)) ; axis%ax_data(:) = data(isc:iec+1) + ! ! A simpler set of labels: do i=1,iec+1-isc ; axis%ax_data(i) = real(isc + i) - 1.5 ; enddo + ! else + ! call MOM_error(FATAL, "Unexpected size of data for "//trim(name)//" in write_metadata_axis.") + ! endif + + ! This works for a simple 1x1 IO layout, but gives errors for nontrivial IO layouts + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) + + else ! Store the entire array of axis labels. + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) + endif + endif + + + ! Now create the variable that describes this axis. + call register_field(IO_handle%fileobj, trim(name), "double", dimensions=(/name/)) + if (len_trim(longname) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & + trim(longname), len_trim(longname)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) + if (present(cartesian)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'cartesian_axis', & + trim(cartesian), len_trim(cartesian)) + if (present(sense)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'sense', sense) + else + if (present(data)) then + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) + endif + + call mpp_write_meta(IO_handle%unit, axis%AT, name, units, longname, cartesian=cartesian, sense=sense, & + domain=domain, data=data, calendar=calendar) + endif +end subroutine write_metadata_axis + +!> Store information about an output variable in a previously defined fieldtype and write this +!! information to the file indicated by unit. +subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & + pack, standard_name, checksum) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(inout) :: field !< The fieldtype where this information is stored + type(axistype), dimension(:), intent(in) :: axes !< Handles for the axis used for this variable + character(len=*), intent(in) :: name !< The name in the file of this variable + character(len=*), intent(in) :: units !< The units of this variable + character(len=*), intent(in) :: longname !< The long description of this variable + integer, optional, intent(in) :: pack !< A precision reduction factor with which the + !! variable. The default, 1, has no reduction, + !! but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), & + optional, intent(in) :: checksum !< Checksum values that can be used to verify reads. + + ! Local variables + character(len=256), dimension(size(axes)) :: dim_names ! The names of the dimensions + type(mpp_axistype), dimension(size(axes)) :: mpp_axes ! The array of mpp_axistypes for this variable + character(len=16) :: prec_string ! A string specifying the precision with which to save this variable + character(len=64) :: checksum_string ! checksum character array created from checksum argument + integer :: i, ndims + + ndims = size(axes) + if (IO_handle%FMS2_file) then + do i=1,ndims ; dim_names(i) = trim(axes(i)%name) ; enddo + prec_string = "double" ; if (present(pack)) then ; if (pack > 1) prec_string = "float" ; endif + call register_field(IO_handle%fileobj, trim(name), trim(prec_string), dimensions=dim_names) + if (len_trim(longname) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & + trim(longname), len_trim(longname)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) + if (present(standard_name)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'standard_name', & + trim(standard_name), len_trim(standard_name)) + if (present(checksum)) then + write (checksum_string,'(Z16)') checksum(1) ! Z16 is the hexadecimal format code + call register_variable_attribute(IO_handle%fileobj, trim(name), "checksum", & + trim(checksum_string), len_trim(checksum_string)) + endif + else + do i=1,ndims ; mpp_axes(i) = axes(i)%AT ; enddo + call mpp_write_meta(IO_handle%unit, field%FT, mpp_axes, name, units, longname, & + pack=pack, standard_name=standard_name, checksum=checksum) + ! unused opt. args: min=min, max=max, fill=fill, scale=scale, add=add, & + endif + + ! Store information in the field-type, regardless of which interfaces are used. + field%name = trim(name) + field%longname = trim(longname) + field%units = trim(units) + field%chksum_read = -1 + field%valid_chksum = .false. + +end subroutine write_metadata_field + +!> Write a global text attribute to a file. +subroutine write_metadata_global(IO_handle, name, attribute) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + character(len=*), intent(in) :: name !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute !< The value of this attribute + + if (IO_handle%FMS2_file) then + call register_global_attribute(IO_handle%fileobj, name, attribute, len_trim(attribute)) + else + call mpp_write_meta(IO_handle%unit, name, cval=attribute) + endif + +end subroutine write_metadata_global + +end module MOM_io_infra diff --git a/config_src/infra/FMS2/MOM_time_manager.F90 b/config_src/infra/FMS2/MOM_time_manager.F90 new file mode 100644 index 0000000000..5f3279b713 --- /dev/null +++ b/config_src/infra/FMS2/MOM_time_manager.F90 @@ -0,0 +1,54 @@ +!> Wraps the FMS time manager functions +module MOM_time_manager + +! This file is part of MOM6. See LICENSE.md for the license. + +use time_manager_mod, only : time_type, get_time, set_time +use time_manager_mod, only : time_type_to_real, real_to_time_type +use time_manager_mod, only : operator(+), operator(-), operator(*), operator(/) +use time_manager_mod, only : operator(>), operator(<), operator(>=), operator(<=) +use time_manager_mod, only : operator(==), operator(/=), operator(//) +use time_manager_mod, only : set_ticks_per_second , get_ticks_per_second +use time_manager_mod, only : get_date, set_date, increment_date +use time_manager_mod, only : days_in_month, month_name +use time_manager_mod, only : set_calendar_type, get_calendar_type +use time_manager_mod, only : JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN +use time_manager_mod, only : NO_CALENDAR + +implicit none ; private + +public :: time_type, get_time, set_time +public :: time_type_to_real, real_to_time_type, real_to_time +public :: set_ticks_per_second, get_ticks_per_second +public :: operator(+), operator(-), operator(*), operator(/) +public :: operator(>), operator(<), operator(>=), operator(<=) +public :: operator(==), operator(/=), operator(//) +public :: get_date, set_date, increment_date, month_name, days_in_month +public :: JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN, NO_CALENDAR +public :: set_calendar_type, get_calendar_type + +contains + +!> Returns a time_type version of a real time in seconds, using an alternate implementation to the +!! FMS function real_to_time_type that is accurate over a larger range of input values. With 32 bit +!! signed integers, this version should work over the entire valid range (2^31 days or ~5.8835 +!! million years) of time_types, whereas the standard version in the FMS time_manager stops working +!! for conversions of times greater than 2^31 seconds, or ~68.1 years. +type(time_type) function real_to_time(x, err_msg) +! type(time_type) :: real_to_time !< The output time as a time_type + real, intent(in) :: x !< The input time in real seconds. + character(len=*), optional, intent(out) :: err_msg !< An optional returned error message. + + ! Local variables + integer :: seconds, days, ticks + real :: real_subsecond_remainder + + days = floor(x/86400.) + seconds = floor(x - 86400.*days) + real_subsecond_remainder = x - (days*86400. + seconds) + ticks = nint(real_subsecond_remainder * get_ticks_per_second()) + + real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg) +end function real_to_time + +end module MOM_time_manager diff --git a/config_src/dynamic/MOM_memory.h b/config_src/memory/dynamic_nonsymmetric/MOM_memory.h similarity index 100% rename from config_src/dynamic/MOM_memory.h rename to config_src/memory/dynamic_nonsymmetric/MOM_memory.h diff --git a/config_src/dynamic_symmetric/MOM_memory.h b/config_src/memory/dynamic_symmetric/MOM_memory.h similarity index 100% rename from config_src/dynamic_symmetric/MOM_memory.h rename to config_src/memory/dynamic_symmetric/MOM_memory.h diff --git a/docs/Doxyfile_nortd b/docs/Doxyfile_nortd index ca18bf49ee..4a81c20bd7 100644 --- a/docs/Doxyfile_nortd +++ b/docs/Doxyfile_nortd @@ -860,10 +860,10 @@ WARN_LOGFILE = _build/doxygen_warn_nortd_log.txt INPUT = ../src \ front_page.md \ - ../config_src/solo_driver \ - ../config_src/dynamic_symmetric \ + ../config_src/drivers/solo_driver \ + ../config_src/memory/dynamic_symmetric \ ../config_src/external \ - ../config_src/coupled_driver + ../config_src/drivers/FMS_cap # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses @@ -2212,7 +2212,7 @@ SEARCH_INCLUDES = YES # This tag requires that the tag SEARCH_INCLUDES is set to YES. INCLUDE_PATH = ../src/framework \ - ../config_src/dynamic_symmetric + ../config_src/memory/dynamic_symmetric # You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard # patterns (like *.h and *.hpp) to filter out the header-files in the diff --git a/docs/Doxyfile_nortd_latex b/docs/Doxyfile_nortd_latex index f779d0215d..207e645195 100644 --- a/docs/Doxyfile_nortd_latex +++ b/docs/Doxyfile_nortd_latex @@ -860,10 +860,10 @@ WARN_LOGFILE = _build/doxygen_warn_nortd_latex_log.txt INPUT = ../src \ front_page.md \ - ../config_src/solo_driver \ - ../config_src/dynamic_symmetric \ + ../config_src/drivers/solo_driver \ + ../config_src/memory/dynamic_symmetric \ ../config_src/external \ - ../config_src/coupled_driver + ../config_src/drivers/FMS_cap # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses @@ -2212,7 +2212,7 @@ SEARCH_INCLUDES = YES # This tag requires that the tag SEARCH_INCLUDES is set to YES. INCLUDE_PATH = ../src/framework \ - ../config_src/dynamic_symmetric + ../config_src/memory/dynamic_symmetric # You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard # patterns (like *.h and *.hpp) to filter out the header-files in the diff --git a/docs/Doxyfile_rtd b/docs/Doxyfile_rtd index 561de8382d..479c03e1b4 100644 --- a/docs/Doxyfile_rtd +++ b/docs/Doxyfile_rtd @@ -810,10 +810,10 @@ WARN_LOGFILE = _build/doxygen_warn_rtd_log.txt # Note: If this tag is empty the current directory is searched. INPUT = ../src \ - ../config_src/solo_driver \ - ../config_src/dynamic_symmetric \ + ../config_src/drivers/solo_driver \ + ../config_src/memory/dynamic_symmetric \ ../config_src/external \ - ../config_src/coupled_driver + ../config_src/drivers/FMS_cap # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses @@ -2072,7 +2072,7 @@ SEARCH_INCLUDES = YES # preprocessor. # This tag requires that the tag SEARCH_INCLUDES is set to YES. -INCLUDE_PATH = ../src/framework ../config_src/dynamic_symmetric +INCLUDE_PATH = ../src/framework ../config_src/memory/dynamic_symmetric # You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard # patterns (like *.h and *.hpp) to filter out the header-files in the diff --git a/docs/Doxyfile_rtd_dox b/docs/Doxyfile_rtd_dox index b9c7c3c0d3..c7919584dd 100644 --- a/docs/Doxyfile_rtd_dox +++ b/docs/Doxyfile_rtd_dox @@ -810,10 +810,10 @@ WARN_LOGFILE = _build/doxygen_rtd_dox_debug.txt # Note: If this tag is empty the current directory is searched. INPUT = ../src \ - ../config_src/solo_driver \ - ../config_src/dynamic_symmetric \ + ../config_src/drivers/solo_driver \ + ../config_src/memory/dynamic_symmetric \ ../config_src/external \ - ../config_src/coupled_driver \ + ../config_src/drivers/FMS_cap \ ../src/ALE/MOM_ALE.F90 \ ../src/ALE/PCM_functions.F90 \ ../src/core/MOM.F90 \ @@ -838,10 +838,10 @@ INPUT = ../src \ #INPUT = ../src/equation_of_state #INPUT = ../src/ALE \ -# ../config_src/solo_driver \ -# ../config_src/dynamic_symmetric \ +# ../config_src/drivers/solo_driver \ +# ../config_src/memory/dynamic_symmetric \ # ../config_src/external \ -# ../config_src/coupled_driver +# ../config_src/drivers/FMS_cap #INPUT = \ # ../src/ALE/_ALE.dox \ @@ -2112,7 +2112,7 @@ SEARCH_INCLUDES = YES # preprocessor. # This tag requires that the tag SEARCH_INCLUDES is set to YES. -INCLUDE_PATH = ../src/framework ../config_src/dynamic_symmetric +INCLUDE_PATH = ../src/framework ../config_src/memory/dynamic_symmetric # You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard # patterns (like *.h and *.hpp) to filter out the header-files in the diff --git a/docs/README.md b/docs/README.md index b071ce5927..1bec91f288 100644 --- a/docs/README.md +++ b/docs/README.md @@ -53,15 +53,19 @@ The starting state of directories and files: ``` SRC/ config_src/ - coupled_driver - dynamic - dynamic_symmetric + drivers/ + FMS_cap + ice_solo_driver + mct_cap + nuopc_cap + solo_driver + unit_drivers external - ice_solo_driver - mct_driver - nuopc_driver - solo_driver - unit_drivers + infra/ + FMS1 + memory/ + dynamic + dynamic_symmetric pkg/ CVMix-src GSW-Fortran diff --git a/docs/code_organization.rst b/docs/code_organization.rst index c83997497d..8e5ac39d57 100644 --- a/docs/code_organization.rst +++ b/docs/code_organization.rst @@ -34,17 +34,19 @@ The directory tree is:: MOM6 ├── config_src - │   ├── coupled_driver - │   ├── dynamic - │   ├── dynamic_symmetric + │   ├── drivers + │   │   ├── FMS_cap + │   │   ├── ice_solo_driver + │   │   ├── mct_cap + │   │   ├── nuopc_cap + │   │   ├── solo_driver + │   │   └── unit_drivers │   ├── external │   │   ├── GFDL_ocean_BGC │   │   └── ODA_hooks - │   ├── ice_solo_driver - │   ├── mct_driver - │   ├── nuopc_driver - │   ├── solo_driver - │   └── unit_drivers + │   ├── memory + │   │   ├── dynamic_nonsymmetric + │   │   ├── dynamic_symmetric ├── docs │   └── images ├── pkg @@ -84,11 +86,11 @@ The directory tree is:: `config_src/` ------------- -`dynamic/`, `dynamic_symmetric/` - One or none of `config_src/dynamic/` or `config_src/dynamic_symmetric/` can - be included at compile time. If neither is used then a `MOM_memory.h` file - specific to the model configuration must be present - this is known as a - "static" compile with fixed layout and domain shape. +`memory/dynamic_nonsymmetric/`, `memory/dynamic_symmetric/` + One or none of `config_src/memory/dynamic_nonsymmetric/` or + `config_src/dynamic_symmetric/` can be included at compile time. If neither + is used then a `MOM_memory.h` file specific to the model configuration must be + present - this is known as a"static" compile with fixed layout and domain shape. `external/` Contains "null" modules providing the API to optional components to use @@ -98,12 +100,17 @@ The directory tree is:: To use the actual ODA or BGC, add the appropriate source to the search paths . -`solo_driver/` +`infra/FMS1` + Contains MOM6-specific thin wrappers to all of the FMS types and routines that + are used by MOM6. The code in this directory should only be called by the + infrastructure-agnostic code in src/framework. + +`drivers/solo_driver/` This driver produces an ocean-only executable with no other coupled components (no sea-ice, no atmosphere, etc.). It is the simplest configuration and fastest to compile and thus used for a lot of testing. -`coupled_driver/` +`drivers/FMS_cap/` This driver provides an interface for the GFDL coupler to call. It requires compiling MOM6 along with at least a sea-ice model and possibly all other components in a coupled model. diff --git a/pkg/CVMix-src b/pkg/CVMix-src index 534fc38e75..9423197f89 160000 --- a/pkg/CVMix-src +++ b/pkg/CVMix-src @@ -1 +1 @@ -Subproject commit 534fc38e759fcb8a2563fa0dc4c0bbf81f758db9 +Subproject commit 9423197f894112edfcb1502245f7d7b873d551f9 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9b94a96797..9ccb8eb8c6 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -41,7 +41,7 @@ module MOM use MOM_obsolete_params, only : find_obsolete_params use MOM_restart, only : register_restart_field, register_restart_pair use MOM_restart, only : query_initialized, save_restart -use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS +use MOM_restart, only : restart_init, is_new_run, determine_is_new_run, MOM_restart_CS use MOM_spatial_means, only : global_mass_integral use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) @@ -97,6 +97,7 @@ module MOM use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_init use MOM_set_visc, only : set_visc_register_restarts, set_visc_CS +use MOM_shared_initialization, only : write_ocean_geometry_file use MOM_sponge, only : init_sponge_diags, sponge_CS use MOM_state_initialization, only : MOM_initialize_state use MOM_sum_output, only : write_energy, accumulate_net_input @@ -1677,7 +1678,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & real :: default_val ! default value for a parameter logical :: write_geom_files ! If true, write out the grid geometry files. logical :: ensemble_ocean ! If true, perform an ensemble gather at the end of step_MOM - logical :: new_sim + logical :: new_sim ! If true, this has been determined to be a new simulation logical :: use_geothermal ! If true, apply geothermal heating. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. logical :: symmetric ! If true, use symmetric memory allocation. @@ -2034,11 +2035,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "vertical grid files. Other values are invalid.", default=1) if (write_geom<0 .or. write_geom>2) call MOM_error(FATAL,"MOM: "//& "WRITE_GEOM must be equal to 0, 1 or 2.") - write_geom_files = ((write_geom==2) .or. ((write_geom==1) .and. & - ((dirs%input_filename(1:1)=='n') .and. (LEN_TRIM(dirs%input_filename)==1)))) -! If the restart file type had been initialized, this could become: -! write_geom_files = ((write_geom==2) .or. & -! ((write_geom==1) .and. is_new_run(restart_CSp))) ! Check for inconsistent parameter settings. if (CS%use_ALE_algorithm .and. bulkmixedlayer) call MOM_error(FATAL, & @@ -2136,8 +2132,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call clone_MOM_domain(G_in%Domain, dG_in%Domain) ! Allocate initialize time-invariant MOM variables. - call MOM_initialize_fixed(dG_in, US, OBC_in, param_file, write_geom_files, & - dirs%output_directory) + call MOM_initialize_fixed(dG_in, US, OBC_in, param_file, .false., dirs%output_directory) call callTree_waypoint("returned from MOM_initialize_fixed() (initialize_MOM)") @@ -2341,17 +2336,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call callTree_waypoint("restart registration complete (initialize_MOM)") - ! Initialize dynamically evolving fields, perhaps from restart files. - call cpu_clock_begin(id_clock_MOM_init) - call MOM_initialize_coord(GV, US, param_file, write_geom_files, & - dirs%output_directory, CS%tv, dG%max_depth) - call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") - - if (CS%use_ALE_algorithm) then - call ALE_init(param_file, GV, US, dG%max_depth, CS%ALE_CSp) - call callTree_waypoint("returned from ALE_init() (initialize_MOM)") - endif - ! Shift from using the temporary dynamic grid type to using the final ! (potentially static) ocean-specific grid type. ! The next line would be needed if G%Domain had not already been init'd above: @@ -2366,10 +2350,26 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) + if (.not. CS%rotate_index) G => G_in + + new_sim = determine_is_new_run(dirs%input_filename, dirs%restart_input_dir, G_in, restart_CSp) + write_geom_files = ((write_geom==2) .or. ((write_geom==1) .and. new_sim)) + + ! Write out all of the grid data used by this run. + if (write_geom_files) call write_ocean_geometry_file(dG_in, param_file, dirs%output_directory, US=US) + call destroy_dyn_horgrid(dG_in) - if (.not. CS%rotate_index) & - G => G_in + ! Initialize dynamically evolving fields, perhaps from restart files. + call cpu_clock_begin(id_clock_MOM_init) + call MOM_initialize_coord(GV, US, param_file, write_geom_files, & + dirs%output_directory, CS%tv, G%max_depth) + call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") + + if (CS%use_ALE_algorithm) then + call ALE_init(param_file, GV, US, G%max_depth, CS%ALE_CSp) + call callTree_waypoint("returned from ALE_init() (initialize_MOM)") + endif ! Set a few remaining fields that are specific to the ocean grid type. call set_first_direction(G, first_direction) @@ -2843,9 +2843,9 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) call find_eta(CS%h, CS%tv, G, GV, US, z_interface, eta_to_m=1.0) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & "Interface heights", "meter", z_grid='i') - + ! NOTE: write_ic=.true. routes routine to fms2 IO write_initial_conditions interface call save_restart(dirs%output_directory, Time, CS%G_in, & - restart_CSp_tmp, filename=CS%IC_file, GV=GV) + restart_CSp_tmp, filename=CS%IC_file, GV=GV, write_ic=.true.) deallocate(z_interface) deallocate(restart_CSp_tmp) endif diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 8dab711d32..b12d3e37e7 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -76,8 +76,10 @@ module MOM_CoriolisAdv integer :: id_rvxu = -1, id_rvxv = -1 ! integer :: id_hf_gKEu = -1, id_hf_gKEv = -1 integer :: id_hf_gKEu_2d = -1, id_hf_gKEv_2d = -1 + integer :: id_intz_gKEu_2d = -1, id_intz_gKEv_2d = -1 ! integer :: id_hf_rvxu = -1, id_hf_rvxv = -1 integer :: id_hf_rvxu_2d = -1, id_hf_rvxv_2d = -1 + integer :: id_intz_rvxu_2d = -1, id_intz_rvxv_2d = -1 !>@} end type CoriolisAdv_CS @@ -168,6 +170,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) ! discretization [H-1 s-1 ~> m-1 s-1 or m2 kg-1 s-1]. real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! Contributions to the circulation around q-points [L2 T-1 ~> m2 s-1] + rel_vort, & ! Relative vorticity at q-points [T-1 ~> s-1]. abs_vort, & ! Absolute vorticity at q-points [T-1 ~> s-1]. q2, & ! Relative vorticity over thickness [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. max_fvq, & ! The maximum of the adjacent values of (-u) times absolute vorticity [L T-2 ~> m s-2]. @@ -177,7 +180,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & PV, & ! A diagnostic array of the potential vorticities [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. RV ! A diagnostic array of the relative vorticities [T-1 ~> s-1]. - real :: fv1, fv2, fu1, fu2 ! (f+rv)*v or (f+rv)*u [L T-2 ~> m s-2]. + real :: fv1, fv2, fv3, fv4 ! (f+rv)*v [L T-2 ~> m s-2]. + real :: fu1, fu2, fu3, fu4 ! -(f+rv)*u [L T-2 ~> m s-2]. real :: max_fv, max_fu ! The maximum or minimum of the neighboring Coriolis real :: min_fv, min_fu ! accelerations [L T-2 ~> m s-2], i.e. max(min)_fu(v)q. @@ -189,8 +193,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) real :: max_Ihq, min_Ihq ! The maximum and minimum of the nearby Ihq [H-1 ~> m-1 or m2 kg-1]. real :: hArea_q ! The sum of area times thickness of the cells ! surrounding a q point [H L2 ~> m3 or kg]. - real :: h_neglect ! A thickness that is so small it is usually - ! lost in roundoff and can be neglected [H ~> m or kg m-2]. + real :: vol_neglect ! A volume so small that is expected to be + ! lost in roundoff [H L2 ~> m3 or kg]. real :: temp1, temp2 ! Temporary variables [L2 T-2 ~> m2 s-2]. real :: eps_vel ! A tiny, positive velocity [L T-1 ~> m s-1]. @@ -219,12 +223,17 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) real, allocatable, dimension(:,:) :: & hf_gKEu_2d, hf_gKEv_2d, & ! Depth sum of hf_gKEu, hf_gKEv [L T-2 ~> m s-2]. hf_rvxu_2d, hf_rvxv_2d ! Depth sum of hf_rvxu, hf_rvxv [L T-2 ~> m s-2]. + !real, allocatable, dimension(:,:,:) :: & ! hf_gKEu, hf_gKEv, & ! accel. due to KE gradient x fract. thickness [L T-2 ~> m s-2]. ! hf_rvxu, hf_rvxv ! accel. due to RV x fract. thickness [L T-2 ~> m s-2]. ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. ! The code is retained for degugging purposes in the future. +! Diagnostics for depth-integrated momentum budget terms + real, dimension(SZIB_(G),SZJ_(G)) :: intz_gKEu_2d, intz_rvxv_2d ! [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJB_(G)) :: intz_gKEv_2d, intz_rvxu_2d ! [L2 T-2 ~> m2 s-2]. + ! To work, the following fields must be set outside of the usual ! is to ie range before this subroutine is called: ! v(is-1:ie+2,js-1:je+1), u(is-1:ie+1,js-1:je+2), h(is-1:ie+2,js-1:je+2), @@ -234,7 +243,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) "MOM_CoriolisAdv: Module must be initialized before it is used.") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke - h_neglect = GV%H_subroundoff + vol_neglect = GV%H_subroundoff * (1e-4 * US%m_to_L)**2 eps_vel = 1.0e-10*US%m_s_to_L_T h_tiny = GV%Angstrom_H ! Perhaps this should be set to h_neglect instead. @@ -270,7 +279,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) enddo ; enddo !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,GV,CS,AD,Area_h,Area_q,& - !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC,eps_vel) + !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,vol_neglect,h_tiny,OBC,eps_vel) do k=1,nz ! Here the second order accurate layer potential vorticities, q, @@ -288,6 +297,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 hArea_u(I,j) = 0.5*(Area_h(i,j) * h(i,j,k) + Area_h(i+1,j) * h(i+1,j,k)) enddo ; enddo + if (CS%Coriolis_En_Dis) then do j=Jsq,Jeq+1 ; do I=is-1,ie uh_center(I,j) = 0.5 * (G%dy_Cu(I,j) * u(I,j,k)) * (h(i,j,k) + h(i+1,j,k)) @@ -421,45 +431,44 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) endif enddo ; endif + if (CS%no_slip) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + rel_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) + enddo ; enddo + else + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + rel_vort(I,J) = G%mask2dBu(I,J) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) + enddo ; enddo + endif + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - if (CS%no_slip ) then - relative_vorticity = (2.0-G%mask2dBu(I,J)) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) - else - relative_vorticity = G%mask2dBu(I,J) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) - endif - absolute_vorticity = G%CoriolisBu(I,J) + relative_vorticity - Ih = 0.0 - if (Area_q(i,j) > 0.0) then - hArea_q = (hArea_u(I,j) + hArea_u(I,j+1)) + (hArea_v(i,J) + hArea_v(i+1,J)) - Ih = Area_q(i,j) / (hArea_q + h_neglect*Area_q(i,j)) - endif - q(I,J) = absolute_vorticity * Ih - abs_vort(I,J) = absolute_vorticity - Ih_q(I,J) = Ih - - if (CS%bound_Coriolis) then - fv1 = absolute_vorticity * v(i+1,J,k) - fv2 = absolute_vorticity * v(i,J,k) - fu1 = -absolute_vorticity * u(I,j+1,k) - fu2 = -absolute_vorticity * u(I,j,k) - if (fv1 > fv2) then - max_fvq(I,J) = fv1 ; min_fvq(I,J) = fv2 - else - max_fvq(I,J) = fv2 ; min_fvq(I,J) = fv1 - endif - if (fu1 > fu2) then - max_fuq(I,J) = fu1 ; min_fuq(I,J) = fu2 - else - max_fuq(I,J) = fu2 ; min_fuq(I,J) = fu1 - endif - endif + abs_vort(I,J) = G%CoriolisBu(I,J) + rel_vort(I,J) + enddo ; enddo - if (CS%id_rv > 0) RV(I,J,k) = relative_vorticity - if (CS%id_PV > 0) PV(I,J,k) = q(I,J) - if (associated(AD%rv_x_v) .or. associated(AD%rv_x_u)) & - q2(I,J) = relative_vorticity * Ih + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + hArea_q = (hArea_u(I,j) + hArea_u(I,j+1)) + (hArea_v(i,J) + hArea_v(i+1,J)) + Ih_q(I,J) = Area_q(I,J) / (hArea_q + vol_neglect) + q(I,J) = abs_vort(I,J) * Ih_q(I,J) enddo ; enddo + if (CS%id_rv > 0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + RV(I,J,k) = rel_vort(I,J) + enddo ; enddo + endif + + if (CS%id_PV > 0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + PV(I,J,k) = q(I,J) + enddo ; enddo + endif + + if (associated(AD%rv_x_v) .or. associated(AD%rv_x_u)) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + q2(I,J) = rel_vort(I,J) * Ih_q(I,J) + enddo ; enddo + endif + ! a, b, c, and d are combinations of neighboring potential ! vorticities which form the Arakawa and Hsu vorticity advection ! scheme. All are defined at u grid points. @@ -664,27 +673,31 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) (ep_u(i,j)*uh(I-1,j,k) - ep_u(i+1,j)*uh(I+1,j,k)) * G%IdxCu(I,j) enddo ; enddo ; endif - if (CS%bound_Coriolis) then do j=js,je ; do I=Isq,Ieq - max_fv = MAX(max_fvq(I,J), max_fvq(I,J-1)) - min_fv = MIN(min_fvq(I,J), min_fvq(I,J-1)) - ! CAu(I,j,k) = min( CAu(I,j,k), max_fv ) - ! CAu(I,j,k) = max( CAu(I,j,k), min_fv ) - if (CAu(I,j,k) > max_fv) then - CAu(I,j,k) = max_fv - else - if (CAu(I,j,k) < min_fv) CAu(I,j,k) = min_fv - endif + fv1 = abs_vort(I,J) * v(i+1,J,k) + fv2 = abs_vort(I,J) * v(i,J,k) + fv3 = abs_vort(I,J-1) * v(i+1,J-1,k) + fv4 = abs_vort(I,J-1) * v(i,J-1,k) + + max_fv = max(fv1, fv2, fv3, fv4) + min_fv = min(fv1, fv2, fv3, fv4) + + CAu(I,j,k) = min(CAu(I,j,k), max_fv) + CAu(I,j,k) = max(CAu(I,j,k), min_fv) enddo ; enddo endif ! Term - d(KE)/dx. do j=js,je ; do I=Isq,Ieq CAu(I,j,k) = CAu(I,j,k) - KEx(I,j) - if (associated(AD%gradKEu)) AD%gradKEu(I,j,k) = -KEx(I,j) enddo ; enddo + if (associated(AD%gradKEu)) then + do j=js,je ; do I=Isq,Ieq + AD%gradKEu(I,j,k) = -KEx(I,j) + enddo ; enddo + endif ! Calculate the tendencies of meridional velocity due to the Coriolis ! force and momentum advection. On a Cartesian grid, this is @@ -775,21 +788,28 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) if (CS%bound_Coriolis) then do J=Jsq,Jeq ; do i=is,ie - max_fu = MAX(max_fuq(I,J),max_fuq(I-1,J)) - min_fu = MIN(min_fuq(I,J),min_fuq(I-1,J)) - if (CAv(i,J,k) > max_fu) then - CAv(i,J,k) = max_fu - else - if (CAv(i,J,k) < min_fu) CAv(i,J,k) = min_fu - endif + fu1 = -abs_vort(I,J) * u(I,j+1,k) + fu2 = -abs_vort(I,J) * u(I,j,k) + fu3 = -abs_vort(I-1,J) * u(I-1,j+1,k) + fu4 = -abs_vort(I-1,J) * u(I-1,j,k) + + max_fu = max(fu1, fu2, fu3, fu4) + min_fu = min(fu1, fu2, fu3, fu4) + + CAv(I,j,k) = min(CAv(I,j,k), max_fu) + CAv(I,j,k) = max(CAv(I,j,k), min_fu) enddo ; enddo endif ! Term - d(KE)/dy. do J=Jsq,Jeq ; do i=is,ie CAv(i,J,k) = CAv(i,J,k) - KEy(i,J) - if (associated(AD%gradKEv)) AD%gradKEv(i,J,k) = -KEy(i,J) enddo ; enddo + if (associated(AD%gradKEv)) then + do J=Jsq,Jeq ; do i=is,ie + AD%gradKEv(i,J,k) = -KEy(i,J) + enddo ; enddo + endif if (associated(AD%rv_x_u) .or. associated(AD%rv_x_v)) then ! Calculate the Coriolis-like acceleration due to relative vorticity. @@ -883,6 +903,22 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) deallocate(hf_gKEv_2d) endif + if (CS%id_intz_gKEu_2d > 0) then + intz_gKEu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + intz_gKEu_2d(I,j) = intz_gKEu_2d(I,j) + AD%gradKEu(I,j,k) * AD%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_gKEu_2d, intz_gKEu_2d, CS%diag) + endif + + if (CS%id_intz_gKEv_2d > 0) then + intz_gKEv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + intz_gKEv_2d(i,J) = intz_gKEv_2d(i,J) + AD%gradKEv(i,J,k) * AD%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_gKEv_2d, intz_gKEv_2d, CS%diag) + endif + !if (CS%id_hf_rvxv > 0) then ! allocate(hf_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq @@ -918,6 +954,22 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) call post_data(CS%id_hf_rvxu_2d, hf_rvxu_2d, CS%diag) deallocate(hf_rvxu_2d) endif + + if (CS%id_intz_rvxv_2d > 0) then + intz_rvxv_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + intz_rvxv_2d(I,j) = intz_rvxv_2d(I,j) + AD%rv_x_v(I,j,k) * AD%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_rvxv_2d, intz_rvxv_2d, CS%diag) + endif + + if (CS%id_intz_rvxu_2d > 0) then + intz_rvxu_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + intz_rvxu_2d(i,J) = intz_rvxu_2d(i,J) + AD%rv_x_u(i,J,k) * AD%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_rvxu_2d, intz_rvxu_2d, CS%diag) + endif endif end subroutine CorAdCalc @@ -1163,24 +1215,24 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) 'Potential Vorticity', 'm-1 s-1', conversion=GV%m_to_H*US%s_to_T) CS%id_gKEu = register_diag_field('ocean_model', 'gKEu', diag%axesCuL, Time, & - 'Zonal Acceleration from Grad. Kinetic Energy', 'm-1 s-2', conversion=US%L_T2_to_m_s2) + 'Zonal Acceleration from Grad. Kinetic Energy', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_gKEu > 0) call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) CS%id_gKEv = register_diag_field('ocean_model', 'gKEv', diag%axesCvL, Time, & - 'Meridional Acceleration from Grad. Kinetic Energy', 'm-1 s-2', conversion=US%L_T2_to_m_s2) + 'Meridional Acceleration from Grad. Kinetic Energy', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_gKEv > 0) call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) CS%id_rvxu = register_diag_field('ocean_model', 'rvxu', diag%axesCvL, Time, & - 'Meridional Acceleration from Relative Vorticity', 'm-1 s-2', conversion=US%L_T2_to_m_s2) + 'Meridional Acceleration from Relative Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_rvxu > 0) call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) CS%id_rvxv = register_diag_field('ocean_model', 'rvxv', diag%axesCuL, Time, & - 'Zonal Acceleration from Relative Vorticity', 'm-1 s-2', conversion=US%L_T2_to_m_s2) + 'Zonal Acceleration from Relative Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_rvxv > 0) call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) !CS%id_hf_gKEu = register_diag_field('ocean_model', 'hf_gKEu', diag%axesCuL, Time, & ! 'Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & - ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !if (CS%id_hf_gKEu > 0) then ! call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) @@ -1188,15 +1240,15 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) !CS%id_hf_gKEv = register_diag_field('ocean_model', 'hf_gKEv', diag%axesCvL, Time, & ! 'Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & - ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !if (CS%id_hf_gKEv > 0) then ! call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) - ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,JsdB,JedB,nz) !endif CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & - 'm-1 s-2', conversion=US%L_T2_to_m_s2) + 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_gKEu_2d > 0) then call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) @@ -1204,10 +1256,26 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & - 'm-1 s-2', conversion=US%L_T2_to_m_s2) + 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_gKEv_2d > 0) then call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) - call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + endif + + CS%id_intz_gKEu_2d = register_diag_field('ocean_model', 'intz_gKEu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Acceleration from Grad. Kinetic Energy', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_gKEu_2d > 0) then + call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hu,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_intz_gKEv_2d = register_diag_field('ocean_model', 'intz_gKEv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Acceleration from Grad. Kinetic Energy', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_gKEv_2d > 0) then + call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hv,isd,ied,JsdB,JedB,nz) endif !CS%id_hf_rvxu = register_diag_field('ocean_model', 'hf_rvxu', diag%axesCvL, Time, & @@ -1215,7 +1283,7 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !if (CS%id_hf_rvxu > 0) then ! call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) - ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,JsdB,JedB,nz) !endif !CS%id_hf_rvxv = register_diag_field('ocean_model', 'hf_rvxv', diag%axesCuL, Time, & @@ -1227,21 +1295,37 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) !endif CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCv1, Time, & - 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & - 'm-1 s-2', conversion=US%L_T2_to_m_s2) + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_rvxu_2d > 0) then call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) - call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,JsdB,JedB,nz) endif CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & - 'm-1 s-2', conversion=US%L_T2_to_m_s2) + 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_rvxv_2d > 0) then call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) endif + CS%id_intz_rvxu_2d = register_diag_field('ocean_model', 'intz_rvxu_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Acceleration from Relative Vorticity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_rvxu_2d > 0) then + call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hv,isd,ied,JsdB,JedB,nz) + endif + + CS%id_intz_rvxv_2d = register_diag_field('ocean_model', 'intz_rvxv_2d', diag%axesCu1, Time, & + 'Depth-integral of Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_rvxv_2d > 0) then + call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hu,IsdB,IedB,jsd,jed,nz) + endif + end subroutine CoriolisAdv_init !> Destructor for coriolisadv_cs diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 628f8e1c39..17e7ebee40 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -955,6 +955,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(i,J) = 0.0 enddo ; enddo + if (CS%linear_wave_drag) then + !$OMP parallel do default(shared) + do j=CS%jsdw,CS%jedw ; do I=CS%isdw-1,CS%iedw + Rayleigh_u(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=CS%jsdw-1,CS%jedw ; do i=CS%isdw,CS%iedw + Rayleigh_v(i,J) = 0.0 + enddo ; enddo + endif + ! Copy input arrays into their wide-halo counterparts. if (interp_eta_PF) then !$OMP parallel do default(shared) @@ -1900,20 +1911,28 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ; enddo ; enddo !$OMP end do nowait endif + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & - dtbt * ((BT_force_v(i,J) + Cor_v(i,J)) + PFv(i,J))) + dtbt * ((BT_force_v(i,J) + Cor_v(i,J)) + PFv(i,J))) + if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev + enddo ; enddo - if (CS%linear_wave_drag) then + if (CS%linear_wave_drag) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) - else + enddo ; enddo + else + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) - endif - enddo ; enddo + enddo ; enddo + endif if (integral_BT_cont) then !$OMP do schedule(static) @@ -1969,6 +1988,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ; enddo ; enddo !$OMP end do nowait endif + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev vel_prev = ubt(I,j) @@ -1976,15 +1996,23 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, dtbt * ((BT_force_u(I,j) + Cor_u(I,j)) + PFu(I,j))) if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*vel_prev + enddo ; enddo + !$OMP end do nowait - if (CS%linear_wave_drag) then + if (CS%linear_wave_drag) then + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * & - ((Cor_u(I,j) + PFu(I,j)) - ubt(I,j)*Rayleigh_u(I,j)) - else + ((Cor_u(I,j) + PFu(I,j)) - ubt(I,j)*Rayleigh_u(I,j)) + enddo ; enddo + !$OMP end do nowait + else + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * (Cor_u(I,j) + PFu(I,j)) - endif - enddo ; enddo - !$OMP end do nowait + enddo ; enddo + !$OMP end do nowait + endif if (integral_BT_cont) then !$OMP do schedule(static) @@ -2046,14 +2074,20 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, dtbt * ((BT_force_u(I,j) + Cor_u(I,j)) + PFu(I,j))) if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*vel_prev + enddo ; enddo - if (CS%linear_wave_drag) then + if (CS%linear_wave_drag) then + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * & ((Cor_u(I,j) + PFu(I,j)) - ubt(I,j)*Rayleigh_u(I,j)) - else + enddo ; enddo + else + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * (Cor_u(I,j) + PFu(I,j)) - endif - enddo ; enddo + enddo ; enddo + endif if (integral_BT_cont) then !$OMP do schedule(static) @@ -2128,15 +2162,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, dtbt * ((BT_force_v(i,J) + Cor_v(i,J)) + PFv(i,J))) if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev + enddo ; enddo + !$OMP end do nowait - if (CS%linear_wave_drag) then + if (CS%linear_wave_drag) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & - ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) - else + ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) + enddo ; enddo + !$OMP end do nowait + else + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) - endif - enddo ; enddo - !$OMP end do nowait + enddo ; enddo + !$OMP end do nowait + endif + if (integral_BT_cont) then !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev @@ -2632,6 +2675,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo ; enddo endif + if ((present(ADp)) .and. (present(BT_cont)) .and. (associated(ADp%diag_hu))) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%diag_hu(I,j,k) = BT_cont%h_u(I,j,k) + enddo ; enddo ; enddo + endif + if ((present(ADp)) .and. (present(BT_cont)) .and. (associated(ADp%diag_hv))) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%diag_hv(i,J,k) = BT_cont%h_v(i,J,k) + enddo ; enddo ; enddo + endif + if (G%nonblocking_updates) then if (find_etaav) call complete_group_pass(CS%pass_etaav, G%Domain) call complete_group_pass(CS%pass_ubta_uhbta, G%Domain) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index a89514cde4..ef7da5c291 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -161,14 +161,17 @@ module MOM_dynamics_split_RK2 integer :: id_CAu = -1, id_CAv = -1 ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 integer :: id_hf_PFu_2d = -1, id_hf_PFv_2d = -1 + integer :: id_intz_PFu_2d = -1, id_intz_PFv_2d = -1 ! integer :: id_hf_CAu = -1, id_hf_CAv = -1 integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 + integer :: id_intz_CAu_2d = -1, id_intz_CAv_2d = -1 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 ! integer :: id_hf_u_BT_accel = -1, id_hf_v_BT_accel = -1 integer :: id_hf_u_BT_accel_2d = -1, id_hf_v_BT_accel_2d = -1 + integer :: id_intz_u_BT_accel_2d = -1, id_intz_v_BT_accel_2d = -1 !>@} type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the @@ -336,6 +339,12 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s hf_CAu_2d, hf_CAv_2d, & ! Depth integeral of hf_CAu, hf_CAv [L T-2 ~> m s-2]. hf_u_BT_accel_2d, hf_v_BT_accel_2d ! Depth integeral of hf_u_BT_accel, hf_v_BT_accel + real, dimension(SZIB_(G),SZJ_(G)) :: & + intz_PFu_2d, intz_CAu_2d, intz_u_BT_accel_2d ! [L2 T-2 ~> m2 s-2]. + + real, dimension(SZI_(G),SZJB_(G)) :: & + intz_PFv_2d, intz_CAv_2d, intz_v_BT_accel_2d ! [L2 T-2 ~> m2 s-2]. + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. logical :: dyn_p_surf @@ -897,6 +906,21 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! enddo ; enddo ; enddo ! call post_data(CS%id_hf_PFv, hf_PFv, CS%diag) !endif + if (CS%id_intz_PFu_2d > 0) then + intz_PFu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + intz_PFu_2d(I,j) = intz_PFu_2d(I,j) + CS%PFu(I,j,k) * CS%ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_PFu_2d, intz_PFu_2d, CS%diag) + endif + if (CS%id_intz_PFv_2d > 0) then + intz_PFv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + intz_PFv_2d(i,J) = intz_PFv_2d(i,J) + CS%PFv(i,J,k) * CS%ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_PFv_2d, intz_PFv_2d, CS%diag) + endif + if (CS%id_hf_PFu_2d > 0) then allocate(hf_PFu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) hf_PFu_2d(:,:) = 0.0 @@ -930,6 +954,21 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! enddo ; enddo ; enddo ! call post_data(CS%id_hf_CAv, hf_CAv, CS%diag) !endif + if (CS%id_intz_CAu_2d > 0) then + intz_CAu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + intz_CAu_2d(I,j) = intz_CAu_2d(I,j) + CS%CAu(I,j,k) * CS%ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_CAu_2d, intz_CAu_2d, CS%diag) + endif + if (CS%id_intz_CAv_2d > 0) then + intz_CAv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + intz_CAv_2d(i,J) = intz_CAv_2d(i,J) + CS%CAv(i,J,k) * CS%ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_CAv_2d, intz_CAv_2d, CS%diag) + endif + if (CS%id_hf_CAu_2d > 0) then allocate(hf_CAu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) hf_CAu_2d(:,:) = 0.0 @@ -963,6 +1002,21 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! enddo ; enddo ; enddo ! call post_data(CS%id_hf_v_BT_accel, hf_v_BT_accel, CS%diag) !endif + if (CS%id_intz_u_BT_accel_2d > 0) then + intz_u_BT_accel_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + intz_u_BT_accel_2d(I,j) = intz_u_BT_accel_2d(I,j) + CS%u_accel_bt(I,j,k) * CS%ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_u_BT_accel_2d, intz_u_BT_accel_2d, CS%diag) + endif + if (CS%id_intz_v_BT_accel_2d > 0) then + intz_v_BT_accel_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + intz_v_BT_accel_2d(i,J) = intz_v_BT_accel_2d(i,J) + CS%v_accel_bt(i,J,k) * CS%ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_v_BT_accel_2d, intz_v_BT_accel_2d, CS%diag) + endif + if (CS%id_hf_u_BT_accel_2d > 0) then allocate(hf_u_BT_accel_2d(G%IsdB:G%IedB,G%jsd:G%jed)) hf_u_BT_accel_2d(:,:) = 0.0 @@ -1366,7 +1420,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param !CS%id_hf_PFv = register_diag_field('ocean_model', 'hf_PFv', diag%axesCvL, Time, & ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !if(CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) !CS%id_hf_CAu = register_diag_field('ocean_model', 'hf_CAu', diag%axesCuL, Time, & ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & @@ -1376,7 +1430,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param !CS%id_hf_CAv = register_diag_field('ocean_model', 'hf_CAv', diag%axesCvL, Time, & ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !if(CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) CS%id_hf_PFu_2d = register_diag_field('ocean_model', 'hf_PFu_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & @@ -1386,7 +1440,17 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_hf_PFv_2d = register_diag_field('ocean_model', 'hf_PFv_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & conversion=US%L_T2_to_m_s2) - if(CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + if(CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_intz_PFu_2d = register_diag_field('ocean_model', 'intz_PFu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Pressure Force Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_intz_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_PFv_2d = register_diag_field('ocean_model', 'intz_PFv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Pressure Force Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_intz_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) CS%id_hf_CAu_2d = register_diag_field('ocean_model', 'hf_CAu_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & @@ -1396,7 +1460,17 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_hf_CAv_2d = register_diag_field('ocean_model', 'hf_CAv_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & conversion=US%L_T2_to_m_s2) - if(CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + if(CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_intz_CAu_2d = register_diag_field('ocean_model', 'intz_CAu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Coriolis and Advective Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_intz_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_CAv_2d = register_diag_field('ocean_model', 'intz_CAv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Coriolis and Advective Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_intz_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) CS%id_uav = register_diag_field('ocean_model', 'uav', diag%axesCuL, Time, & 'Barotropic-step Averaged Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) @@ -1416,7 +1490,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param !CS%id_hf_v_BT_accel = register_diag_field('ocean_model', 'hf_v_BT_accel', diag%axesCvL, Time, & ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !if(CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) CS%id_hf_u_BT_accel_2d = register_diag_field('ocean_model', 'hf_u_BT_accel_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & @@ -1426,7 +1500,17 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_hf_v_BT_accel_2d = register_diag_field('ocean_model', 'hf_v_BT_accel_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & conversion=US%L_T2_to_m_s2) - if(CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + if(CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_intz_u_BT_accel_2d = register_diag_field('ocean_model', 'intz_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-integral of Barotropic Anomaly Zonal Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_intz_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_v_BT_accel_2d = register_diag_field('ocean_model', 'intz_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-integral of Barotropic Anomaly Meridional Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_intz_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index e1f573f6ea..98b5b10998 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -37,14 +37,14 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !! thermodynamic variables real, intent(in) :: dt_kappa_smooth !< A smoothing vertical diffusivity !! times a smoothing timescale [Z2 ~> m2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-direction [nondim] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-direction [nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-dir [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-dir [Z L-1 ~> nondim] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: N2_u !< Brunt-Vaisala frequency squared at - !! interfaces between u-points [T-2 ~> s-2] + !! interfaces between u-points [L2 Z-2 T-2 ~> s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at - !! interfaces between u-points [T-2 ~> s-2] + !! interfaces between v-points [L2 Z-2 T-2 ~> s-2] integer, optional, intent(in) :: halo !< Halo width over which to compute type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. @@ -86,7 +86,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. real :: Slope ! The slope of density surfaces, calculated in a way ! that is always between -1 and 1. - real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 L-2 ~> kg2 m-8]. + real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 Z-2 ~> kg2 m-8]. real :: slope2_Ratio ! The ratio of the slope squared to slope_max squared. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -94,7 +94,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real :: dz_neglect ! A change in interface heighs that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. - real :: G_Rho0 ! The gravitational acceleration divided by density [Z2 T-2 R-1 ~> m5 kg-2 s-2] + real :: G_Rho0 ! The gravitational acceleration divided by density [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] real :: Z_to_L ! A conversion factor between from units for e to the ! units for lateral distances. real :: L_to_Z ! A conversion factor between from units for lateral distances @@ -134,7 +134,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & present_N2_u = PRESENT(N2_u) present_N2_v = PRESENT(N2_v) - G_Rho0 = (US%L_to_Z*L_to_Z*GV%g_Earth) / GV%Rho0 + G_Rho0 = GV%g_Earth / GV%Rho0 if (present_N2_u) then do j=js,je ; do I=is-1,ie N2_u(I,j,1) = 0. @@ -248,17 +248,17 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = drdx**2 + (L_to_Z*drdz)**2 + mag_grad2 = (Z_to_L*drdx)**2 + drdz**2 if (mag_grad2 > 0.0) then slope_x(I,j,K) = drdx / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. slope_x(I,j,K) = 0.0 endif - if (present_N2_u) N2_u(I,j,k) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of buoyancy frequency [T-2 ~> s-2] + if (present_N2_u) N2_u(I,j,k) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] else ! With .not.use_EOS, the layers are constant density. - slope_x(I,j,K) = (Z_to_L*(e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) + slope_x(I,j,K) = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu(I,j) endif if (local_open_u_BC) then l_seg = OBC%segnum_u(I,j) @@ -351,17 +351,17 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = drdy**2 + (L_to_Z*drdz)**2 + mag_grad2 = (Z_to_L*drdy)**2 + drdz**2 if (mag_grad2 > 0.0) then slope_y(i,J,K) = drdy / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. slope_y(i,J,K) = 0.0 endif - if (present_N2_v) N2_v(i,J,k) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of buoyancy frequency [T-2 ~> s-2] + if (present_N2_v) N2_v(i,J,k) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] else ! With .not.use_EOS, the layers are constant density. - slope_y(i,J,K) = (Z_to_L*(e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) + slope_y(i,J,K) = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv(i,J) endif if (local_open_v_BC) then l_seg = OBC%segnum_v(i,J) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index d81cf28e17..886ee77510 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -188,6 +188,9 @@ module MOM_variables real, pointer :: diag_hfrac_u(:,:,:) => NULL() !< Fractional layer thickness at u points real, pointer :: diag_hfrac_v(:,:,:) => NULL() !< Fractional layer thickness at v points + real, pointer :: diag_hu(:,:,:) => NULL() !< layer thickness at u points + real, pointer :: diag_hv(:,:,:) => NULL() !< layer thickness at v points + end type accel_diag_ptrs !> Pointers to arrays with transports, which can later be used for derived diagnostics, like energy balances. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 47d322dfa0..bb5243892d 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1767,7 +1767,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag ! call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) ! call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) ! endif - ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) !endif CS%id_hf_du_dt_2d = register_diag_field('ocean_model', 'hf_dudt_2d', diag%axesCu1, Time, & @@ -1787,7 +1787,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) endif - call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) endif ! layer thickness variables diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 5c503836f0..7b073e8a0b 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -5,14 +5,14 @@ module MOM_checksums use MOM_array_transform, only : rotate_array, rotate_array_pair, rotate_vector use MOM_array_transform, only : allocate_rotated_array -use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs -use MOM_coms, only : min_across_PEs, max_across_PEs -use MOM_coms, only : reproducing_sum, field_chksum -use MOM_error_handler, only : MOM_error, FATAL, is_root_pe -use MOM_file_parser, only : log_version, param_file_type -use MOM_hor_index, only : hor_index_type, rotate_hor_index +use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs +use MOM_coms, only : min_across_PEs, max_across_PEs +use MOM_coms, only : reproducing_sum, field_chksum +use MOM_error_handler, only : MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : log_version, param_file_type +use MOM_hor_index, only : hor_index_type, rotate_hor_index -use iso_fortran_env, only: error_unit +use iso_fortran_env, only : error_unit, int32, int64 implicit none ; private @@ -2092,7 +2092,7 @@ function rotated_field_chksum_real_0d(field, pelist, mask_val, turns) & integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum real, optional, intent(in) :: mask_val !< FMS mask value integer, optional, intent(in) :: turns !< Number of quarter turns - integer :: chksum !< checksum of scalar + integer(kind=int64) :: chksum !< checksum of scalar if (present(turns)) call MOM_error(FATAL, "Rotation not supported for 0d fields.") @@ -2107,7 +2107,7 @@ function rotated_field_chksum_real_1d(field, pelist, mask_val, turns) & integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum real, optional, intent(in) :: mask_val !< FMS mask value integer, optional, intent(in) :: turns !< Number of quarter turns - integer :: chksum !< checksum of array + integer(kind=int64) :: chksum !< checksum of array if (present(turns)) call MOM_error(FATAL, "Rotation not supported for 1d fields.") @@ -2122,7 +2122,7 @@ function rotated_field_chksum_real_2d(field, pelist, mask_val, turns) & integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum real, optional, intent(in) :: mask_val !< FMS mask value integer, optional, intent(in) :: turns !< Number of quarter turns - integer :: chksum !< checksum of array + integer(kind=int64) :: chksum !< checksum of array ! Local variables real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units @@ -2149,7 +2149,7 @@ function rotated_field_chksum_real_3d(field, pelist, mask_val, turns) & integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum real, optional, intent(in) :: mask_val !< FMS mask value integer, optional, intent(in) :: turns !< Number of quarter turns - integer :: chksum !< checksum of array + integer(kind=int64) :: chksum !< checksum of array ! Local variables real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units @@ -2176,7 +2176,7 @@ function rotated_field_chksum_real_4d(field, pelist, mask_val, turns) & integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum real, optional, intent(in) :: mask_val !< FMS mask value integer, optional, intent(in) :: turns !< Number of quarter turns - integer :: chksum !< checksum of array + integer(kind=int64) :: chksum !< checksum of array ! Local variables real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index 94014d9a56..73304f7fe8 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -4,31 +4,33 @@ module MOM_coupler_types ! This file is part of MOM6. See LICENSE.md for the license. use MOM_couplertype_infra, only : CT_spawn, CT_initialized, CT_destructor, atmos_ocn_coupler_flux -use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums -use MOM_couplertype_infra, only : CT_copy_data, CT_increment_data, CT_set_data, CT_extract_data -use MOM_couplertype_infra, only : coupler_1d_bc_type, coupler_2d_bc_type +use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums, CT_data_override +use MOM_couplertype_infra, only : CT_copy_data, CT_increment_data, CT_rescale_data +use MOM_couplertype_infra, only : CT_set_data, CT_extract_data, CT_redistribute_data +use MOM_couplertype_infra, only : coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type use MOM_couplertype_infra, only : ind_flux, ind_alpha, ind_csurf - -use MOM_time_manager, only : time_type +use MOM_domain_infra, only : domain2D +use MOM_time_manager, only : time_type implicit none ; private public :: coupler_type_spawn, coupler_type_destructor, coupler_type_initialized public :: coupler_type_set_diags, coupler_type_send_data, coupler_type_write_chksums -public :: set_coupler_type_data, extract_coupler_type_data -public :: coupler_type_copy_data, coupler_type_increment_data -public :: atmos_ocn_coupler_flux +public :: set_coupler_type_data, extract_coupler_type_data, coupler_type_redistribute_data +public :: coupler_type_copy_data, coupler_type_increment_data, coupler_type_rescale_data +public :: atmos_ocn_coupler_flux, coupler_type_data_override public :: ind_flux, ind_alpha, ind_csurf -public :: coupler_1d_bc_type, coupler_2d_bc_type +public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type !> This is the interface to spawn one coupler_bc_type into another. interface coupler_type_spawn - module procedure CT_spawn_1d_2d, CT_spawn_2d_2d + module procedure CT_spawn_1d_2d, CT_spawn_1d_3d, CT_spawn_2d_2d, CT_spawn_2d_3d + module procedure CT_spawn_3d_2d, CT_spawn_3d_3d end interface coupler_type_spawn !> This function interface indicates whether a coupler_bc_type has been initialized. interface coupler_type_initialized - module procedure CT_initialized_1d, CT_initialized_2d + module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d end interface coupler_type_initialized !> This is the interface to deallocate any data associated with a coupler_bc_type. @@ -36,6 +38,36 @@ module MOM_coupler_types module procedure CT_destructor_1d, CT_destructor_2d end interface coupler_type_destructor +!> Copy all elements of the data in either a coupler_2d_bc_type or a coupler_3d_bc_type into +!! another structure of the same or the other type. Both must have the same array sizes in common +!! dimensions, while the details of any expansion from 2d to 3d are controlled by arguments. +interface coupler_type_copy_data + module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d +end interface coupler_type_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type with +!! the data from another. Both must have the same array sizes and rank. +interface coupler_type_increment_data + module procedure CT_increment_data_2d, CT_increment_data_3d, CT_increment_data_2d_3d +end interface coupler_type_increment_data + +!> Rescale the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +interface coupler_type_rescale_data + module procedure CT_rescale_data_2d, CT_rescale_data_3d +end interface coupler_type_rescale_data + +!> Redistribute the data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type into +!! another, which may be on different processors with a different decomposition. +interface coupler_type_redistribute_data + module procedure CT_redistribute_data_2d, CT_redistribute_data_3d +end interface coupler_type_redistribute_data + +!> Write out checksums for the elements of a coupler_2d_bc_type or coupler_3d_bc_type +interface coupler_type_write_chksums + module procedure CT_write_chksums_2d, CT_write_chksums_3d +end interface coupler_type_write_chksums + contains !> Generate a 2-D coupler type using a 1-D coupler type as a template. @@ -54,6 +86,24 @@ subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) end subroutine CT_spawn_1d_2d +!> Generate a 3-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_3d + !> Generate one 2-D coupler type using another 2-D coupler type as a template. subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information @@ -70,8 +120,60 @@ subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) end subroutine CT_spawn_2d_2d -!> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & +!> Generate a 3-D coupler type using a 2-D coupler type as a template. +subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_3d + +!> Generate a 2-D coupler type using a 3-D coupler type as a template. +subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_2d + +!> Generate a 3-D coupler type using another 3-D coupler type as a template. +subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure @@ -89,11 +191,59 @@ subroutine coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, call CT_copy_data(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) -end subroutine coupler_type_copy_data +end subroutine CT_copy_data_2d + +!> Copy all elements of the data in a coupler_3d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call CT_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into a coupler_3d_bc_type. +!! Both must have the same array sizes for the first two dimensions, while the extent +!! of the 3rd dimension that is being filled may be specified via optional arguments. +subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd + !! index of the 3d type to fill in. + integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd + !! index of the 3d type to fill in. + + call CT_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) +end subroutine CT_copy_data_2d_3d !> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both !! must have the same array sizes. -subroutine coupler_type_increment_data(var_in, var, halo_size, scale_factor, scale_prev) +subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default @@ -103,7 +253,96 @@ subroutine coupler_type_increment_data(var_in, var, halo_size, scale_factor, sca call CT_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & scale_prev=scale_prev) -end subroutine coupler_type_increment_data +end subroutine CT_increment_data_2d + +!> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. + + call CT_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev, exclude_flux_type=exclude_flux_type, & + only_flux_type=only_flux_type) + +end subroutine CT_increment_data_3d + +!> Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a +!! coupler_3d_bc_type +subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to + !! increment the 2d-data. There is no renormalization, + !! so if the weights do not sum to 1 in the 3rd dimension + !! there may be adverse consequences! + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + + call CT_increment_data(var_in, weights, var, halo_size=halo_size) + +end subroutine CT_increment_data_2d_3d + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_2d(var, scale) + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call CT_rescale_data(var, scale) + +end subroutine CT_rescale_data_2d + +!> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_3d(var, scale) + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call CT_rescale_data(var, scale) + +end subroutine CT_rescale_data_3d + +!> Redistribute the data in all elements of one coupler_2d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call CT_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_2d + +!> Redistribute the data in all elements of one coupler_3d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call CT_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_3d + + +!> Potentially override the values in a coupler_2d_bc_type +subroutine coupler_type_data_override(gridname, var, time) + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time + + call CT_data_override(gridname, var, time) +end subroutine coupler_type_data_override + !> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array, using a !! MOM-specific interface. @@ -193,14 +432,24 @@ subroutine coupler_type_send_data(var, Time) end subroutine coupler_type_send_data !> Write out checksums for the elements of a coupler_2d_bc_type -subroutine coupler_type_write_chksums(var, outunit, name_lead) +subroutine CT_write_chksums_2d(var, outunit, name_lead) type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics integer, intent(in) :: outunit !< The index of a open output file character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names call CT_write_chksums(var, outunit, name_lead) -end subroutine coupler_type_write_chksums +end subroutine CT_write_chksums_2d + +!> Write out checksums for the elements of a coupler_3d_bc_type +subroutine CT_write_chksums_3d(var, outunit, name_lead) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call CT_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_3d !> Indicate whether a coupler_1d_bc_type has been initialized. logical function CT_initialized_1d(var) @@ -216,6 +465,13 @@ logical function CT_initialized_2d(var) CT_initialized_2d = CT_initialized(var) end function CT_initialized_2d +!> Indicate whether a coupler_3d_bc_type has been initialized. +logical function CT_initialized_3d(var) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_3d = CT_initialized(var) +end function CT_initialized_3d + !> Deallocate all data associated with a coupler_1d_bc_type subroutine CT_destructor_1d(var) type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed diff --git a/src/framework/MOM_couplertype_infra.F90 b/src/framework/MOM_couplertype_infra.F90 deleted file mode 100644 index fd947691ca..0000000000 --- a/src/framework/MOM_couplertype_infra.F90 +++ /dev/null @@ -1,247 +0,0 @@ -!> This module wraps the FMS coupler types module -module MOM_couplertype_infra - -! This file is part of MOM6. See LICENSE.md for the license. - -use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor -use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data -use coupler_types_mod, only : coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_copy_data, coupler_type_increment_data -use coupler_types_mod, only : coupler_type_extract_data, coupler_type_set_data -use coupler_types_mod, only : ind_flux, ind_alpha, ind_csurf -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux -use MOM_time_manager, only : time_type - -implicit none ; private - -public :: CT_spawn, CT_initialized, CT_destructor -public :: CT_set_diags, CT_send_data, CT_write_chksums -public :: CT_set_data, CT_increment_data -public :: CT_copy_data, CT_extract_data -public :: atmos_ocn_coupler_flux -public :: ind_flux, ind_alpha, ind_csurf -public :: coupler_1d_bc_type, coupler_2d_bc_type - -!> This is the interface to spawn one coupler_bc_type into another. -interface CT_spawn - module procedure CT_spawn_1d_2d, CT_spawn_2d_2d -end interface CT_spawn - -!> This function interface indicates whether a coupler_bc_type has been initialized. -interface CT_initialized - module procedure CT_initialized_1d, CT_initialized_2d -end interface CT_initialized - -!> This is the interface to deallocate any data associated with a coupler_bc_type. -interface CT_destructor - module procedure CT_destructor_1d, CT_destructor_2d -end interface CT_destructor - -contains - -!> This subroutine sets many of the parameters for calculating an atmosphere-ocean tracer flux -!! and retuns an integer index for that flux. -function atmos_ocn_coupler_flux(name, flux_type, implementation, param, mol_wt, & - ice_restart_file, ocean_restart_file, units, caller, verbosity) & - result (coupler_index) - - character(len=*), intent(in) :: name !< A name to use for the flux - character(len=*), intent(in) :: flux_type !< A string describing the type of this flux, - !! perhaps 'air_sea_gas_flux'. - character(len=*), intent(in) :: implementation !< A name describing the specific - !! implementation of this flux, such as 'ocmip2'. - real, dimension(:), optional, intent(in) :: param !< An array of parameters used for the fluxes - real, optional, intent(in) :: mol_wt !< The molecular weight of this tracer - character(len=*), optional, intent(in) :: ice_restart_file !< A sea-ice restart file to use with this flux. - character(len=*), optional, intent(in) :: ocean_restart_file !< An ocean restart file to use with this flux. - character(len=*), optional, intent(in) :: units !< The units of the flux - character(len=*), optional, intent(in) :: caller !< The name of the calling routine - integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. - integer :: coupler_index !< The resulting integer handle to use for this flux in subsequent calls. - - coupler_index = aof_set_coupler_flux(name, flux_type, implementation, & - param=param, mol_wt=mol_wt, ice_restart_file=ice_restart_file, & - ocean_restart_file=ocean_restart_file, & - units=units, caller=caller, verbosity=verbosity) - -end function atmos_ocn_coupler_flux - -!> Generate a 2-D coupler type using a 1-D coupler type as a template. -subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) - type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) - -end subroutine CT_spawn_1d_2d - -!> Generate one 2-D coupler type using another 2-D coupler type as a template. -subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) - type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) - -end subroutine CT_spawn_2d_2d - -!> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine CT_copy_data(var_in, var, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy - type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes - !! to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes - !! to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - - call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) -end subroutine CT_copy_data - -!> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both -!! must have the same array sizes. -subroutine CT_increment_data(var_in, var, halo_size, scale_factor, scale_prev) - type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type - type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - - call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & - scale_prev=scale_prev) - -end subroutine CT_increment_data - -!> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array. -subroutine CT_extract_data(var_in, bc_index, field_index, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the boundary - !! condition that is being copied, or the - !! surface flux by default. - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - call coupler_type_extract_data(var_in, bc_index, field_index, array_out, scale_factor, halo_size, idim, jdim) - -end subroutine CT_extract_data - -!> Set single 2d field in coupler_2d_bc_type from a two-dimensional array. -subroutine CT_set_data(array_in, bc_index, field_index, var, & - scale_factor, halo_size, idim, jdim) - real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being set. The - !! surface concentration is set by default. - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - - integer :: subfield ! An integer indicating which field to set. - - call coupler_type_set_data(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim) - -end subroutine CT_set_data - -!> Register the diagnostics of a coupler_2d_bc_type -subroutine CT_set_diags(var, diag_name, axes, time) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file, or blank not to register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - - call coupler_type_set_diags(var, diag_name, axes, time) - -end subroutine CT_set_diags - -!> Write out all diagnostics of elements of a coupler_2d_bc_type -subroutine CT_send_data(var, Time) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write - type(time_type), intent(in) :: time !< The current model time - - call coupler_type_send_data(var, Time) -end subroutine CT_send_data - -!> Write out checksums for the elements of a coupler_2d_bc_type -subroutine CT_write_chksums(var, outunit, name_lead) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics - integer, intent(in) :: outunit !< The index of a open output file - character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names - - call coupler_type_write_chksums(var, outunit, name_lead) - -end subroutine CT_write_chksums - -!> Indicate whether a coupler_1d_bc_type has been initialized. -logical function CT_initialized_1d(var) - type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - - CT_initialized_1d = coupler_type_initialized(var) -end function CT_initialized_1d - -!> Indicate whether a coupler_2d_bc_type has been initialized. -logical function CT_initialized_2d(var) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - - CT_initialized_2d = coupler_type_initialized(var) -end function CT_initialized_2d - -!> Deallocate all data associated with a coupler_1d_bc_type -subroutine CT_destructor_1d(var) - type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - call coupler_type_destructor(var) - -end subroutine CT_destructor_1d - -!> Deallocate all data associated with a coupler_2d_bc_type -subroutine CT_destructor_2d(var) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - call coupler_type_destructor(var) - -end subroutine CT_destructor_2d - -end module MOM_couplertype_infra diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index b4cce081a0..e9ad88c17e 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -4146,42 +4146,36 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 - total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj) - total_weight = total_weight + weight ave = ave+field_in(ii,jj)*weight enddo ; enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave !Masked Sum (total_weight=1) enddo ; enddo elseif (method == PSP) then ! e.g., umo_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 - total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 weight = mask(ii,jj) - total_weight = total_weight +weight ave = ave+field_in(ii,jj)*weight enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave !Masked Sum (total_weight=1) enddo ; enddo elseif (method == SPP) then ! e.g., vmo_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 - total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 weight = mask(ii,jj) - total_weight = total_weight +weight ave = ave+field_in(ii,jj)*weight enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave !Masked Sum (total_weight=1) enddo ; enddo elseif (method == PMP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index b25a934b97..0cdcc455fc 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -8,7 +8,7 @@ module MOM_domains use MOM_coms_infra, only : sum_across_PEs, min_across_PEs, max_across_PEs use MOM_domain_infra, only : MOM_domain_type, domain2D, domain1D, group_pass_type use MOM_domain_infra, only : create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain -use MOM_domain_infra, only : get_domain_extent, get_domain_components +use MOM_domain_infra, only : get_domain_extent, get_domain_components, same_domain use MOM_domain_infra, only : compute_block_extent, get_global_shape use MOM_domain_infra, only : pass_var, pass_vector, fill_symmetric_edges, global_field_sum use MOM_domain_infra, only : pass_var_start, pass_var_complete @@ -33,8 +33,10 @@ module MOM_domains public :: MOM_domains_init, create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain public :: MOM_thread_affinity_set, set_MOM_thread_affinity ! Domain query routines -public :: get_domain_extent, get_domain_components, compute_block_extent, get_global_shape +public :: get_domain_extent, get_domain_components, get_global_shape, same_domain public :: PE_here, root_PE, num_PEs +! Blocks are not actively used in MOM6, so this routine could be deprecated. +public :: compute_block_extent ! Single call communication routines public :: pass_var, pass_vector, fill_symmetric_edges, broadcast ! Non-blocking communication routines diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 8d02dfdf3f..73fb1f0a41 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -11,9 +11,9 @@ module MOM_horizontal_regridding use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_interpolate, only : time_interp_external, get_external_field_info, horiz_interp_init +use MOM_interpolate, only : time_interp_external, horiz_interp_init use MOM_interpolate, only : build_horiz_interp_weights, run_horiz_interp, horiz_interp_type -use MOM_io_infra, only : axistype, get_axis_data +use MOM_interp_infra, only : axistype, get_external_field_info, get_axis_data use MOM_time_manager, only : time_type use netcdf, only : NF90_OPEN, NF90_NOWRITE, NF90_GET_ATT, NF90_GET_VAR diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index f282d03ff6..4a931d0bf3 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -9,7 +9,6 @@ module MOM_interpolate use MOM_interp_infra, only : time_interp_external_init, get_external_field_info use MOM_interp_infra, only : horiz_interp_type, horiz_interp_init use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights -use MOM_io_infra, only : axistype use MOM_time_manager, only : time_type implicit none ; private diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 1159ac87e1..fb1c6b74f1 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -35,7 +35,7 @@ module MOM_io ! These interfaces are actually implemented in this file. public :: create_file, reopen_file, cmor_long_std, ensembler, MOM_io_init -public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc +public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc, position_from_horgrid public :: open_namelist_file, check_namelist_error, check_nml_error public :: get_var_sizes, verify_variable_units, num_timelevels, read_variable, read_attribute public :: open_file_to_read, close_file_to_read @@ -47,6 +47,10 @@ module MOM_io public :: MOM_read_data, MOM_read_vector, read_field_chksum public :: slasher, write_field, write_version_number public :: io_infra_init, io_infra_end +! This is used to set up information descibing non-domain-decomposed axes. +public :: axis_info, set_axis_info, delete_axis_info +! This is used to set up global file attributes +public :: attribute_info, set_attribute_info, delete_attribute_info ! This API is here just to support potential use by non-FMS drivers, and should not persist. public :: read_data !> These encoding constants are used to indicate the file format @@ -94,8 +98,32 @@ module MOM_io character(len=240) :: cmor_longname !< CMOR long name of the variable real :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive + character(len=32) :: dim_names(5) !< The names in the file of the axes for this variable + integer :: position = -1 !< An integer encoding the horizontal position, it may + !! CENTER, CORNER, EAST_FACE, NORTH_FACE, or 0. end type vardesc +!> Type that stores information that can be used to create a non-decomposed axis. +type :: axis_info ; private + character(len=32) :: name = "" !< The name of this axis for use in files + character(len=256) :: longname = "" !< A longer name describing this axis + character(len=48) :: units = "" !< The units of the axis labels + character(len=8) :: cartesian = "N" !< A variable indicating which direction + !! this axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer :: sense = 0 !< This is 1 for axes whose values increase upward, or -1 + !! if they increase downward. The default, 0, is ignored. + integer :: ax_size = 0 !< The number of elements in this axis + real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. +end type axis_info + +!> Type that stores for a global file attribute +type :: attribute_info ; private + character(len=:), allocatable :: name !< The name of this attribute + character(len=:), allocatable :: att_val !< The values of this attribute +end type attribute_info + + integer, public :: stdout = stdout_iso !< standard output unit integer, public :: stderr = stderr_iso !< standard output unit @@ -104,8 +132,9 @@ module MOM_io !> Routine creates a new NetCDF file. It also sets up fieldtype !! structures that describe this file and variables that will !! later be written to this file. -subroutine create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, G, dG, GV, checksums) - type(file_type), intent(inout) :: IO_handle !< Handle for a file or fileset that is to be +subroutine create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & + G, dG, GV, checksums, extra_axes, global_atts) + type(file_type), intent(inout) :: IO_handle !< Handle for a files or fileset that is to be !! opened or reopened for writing character(len=*), intent(in) :: filename !< full path to the file to create type(vardesc), intent(in) :: vars(:) !< structures describing fields written to filename @@ -123,31 +152,47 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is !! required if the new file uses any !! vertical grid axes. - integer(kind=int64), optional, intent(in) :: checksums(:,:) !< checksums of vars + integer(kind=int64), optional, intent(in) :: checksums(:,:) !< checksums of vars + type(axis_info), optional, intent(in) :: extra_axes(:) !< Types with information about + !! some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) !< Global attributes to + !! write to this file logical :: use_lath, use_lonh, use_latq, use_lonq, use_time logical :: use_layer, use_int, use_periodic - logical :: one_file, domain_set + logical :: one_file, domain_set, dim_found + logical, dimension(:), allocatable :: use_extra_axis type(axistype) :: axis_lath, axis_latq, axis_lonh, axis_lonq type(axistype) :: axis_layer, axis_int, axis_time, axis_periodic - type(axistype) :: axes(4) + type(axistype), dimension(:), allocatable :: more_axes ! Axes generated from extra_axes + type(axistype) :: axes(5) ! The axes of a variable type(MOM_domain_type), pointer :: Domain => NULL() type(domain1d) :: x_domain, y_domain - integer :: numaxes, pack, thread, k + integer :: position, numaxes, pack, thread, k, n, m + integer :: num_extra_dims ! The number of extra possible dimensions from extra_axes integer :: isg, ieg, jsg, jeg, IsgB, IegB, JsgB, JegB integer :: var_periods, num_periods=0 - real, dimension(:), allocatable :: period_val + real, dimension(:), allocatable :: axis_val real, pointer, dimension(:) :: & gridLatT => NULL(), & ! The latitude or longitude of T or B points for gridLatB => NULL(), & ! the purpose of labeling the output axes. gridLonT => NULL(), gridLonB => NULL() character(len=40) :: time_units, x_axis_units, y_axis_units character(len=8) :: t_grid, t_grid_read + character(len=64) :: ax_name(5) ! The axis names of a variable use_lath = .false. ; use_lonh = .false. use_latq = .false. ; use_lonq = .false. use_time = .false. ; use_periodic = .false. use_layer = .false. ; use_int = .false. + num_extra_dims = 0 + if (present(extra_axes)) then + num_extra_dims = size(extra_axes) + if (num_extra_dims > 0) then + allocate(use_extra_axis(num_extra_dims)) ; use_extra_axis = .false. + allocate(more_axes(num_extra_dims)) + endif + endif thread = SINGLE_FILE if (PRESENT(threading)) thread = threading @@ -180,19 +225,16 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim ! Define the coordinates. do k=1,novars - select case (vars(k)%hor_grid) - case ('h') ; use_lath = .true. ; use_lonh = .true. - case ('q') ; use_latq = .true. ; use_lonq = .true. - case ('u') ; use_lath = .true. ; use_lonq = .true. - case ('v') ; use_latq = .true. ; use_lonh = .true. - case ('T') ; use_lath = .true. ; use_lonh = .true. - case ('Bu') ; use_latq = .true. ; use_lonq = .true. - case ('Cu') ; use_lath = .true. ; use_lonq = .true. - case ('Cv') ; use_latq = .true. ; use_lonh = .true. - case ('1') ! Do nothing. + position = vars(k)%position + if (position == -1) position = position_from_horgrid(vars(k)%hor_grid) + select case (position) + case (CENTER) ; use_lath = .true. ; use_lonh = .true. + case (CORNER) ; use_latq = .true. ; use_lonq = .true. + case (EAST_FACE) ; use_lath = .true. ; use_lonq = .true. + case (NORTH_FACE) ; use_latq = .true. ; use_lonh = .true. + case (0) ! Do nothing. case default - call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& - " has unrecognized hor_grid "//trim(vars(k)%hor_grid)) + call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//" has an unrecognized value of postion") end select select case (vars(k)%z_grid) case ('L') ; use_layer = .true. @@ -233,6 +275,19 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& " has unrecognized t_grid "//trim(vars(k)%t_grid)) end select + + do n=1,5 ; if (len_trim(vars(k)%dim_names(n)) > 0) then + dim_found = .false. + do m=1,num_extra_dims + if (lowercase(trim(vars(k)%dim_names(n))) == lowercase(trim(extra_axes(m)%name))) then + use_extra_axis(m) = .true. + dim_found = .true. + exit + endif + enddo + if (.not.dim_found) call MOM_error(FATAL, "Unable to find a match for dimension "//& + trim(vars(k)%dim_names(n))//" for variable "//trim(vars(k)%name)//" in file "//trim(filename)) + endif ; enddo enddo if ((use_lath .or. use_lonh .or. use_latq .or. use_lonq)) then @@ -254,11 +309,11 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim if (use_latq) & call write_metadata(IO_handle, axis_latq, name="latq", units=y_axis_units, longname="Latitude", & - cartesian='Y', domain=y_domain, data=gridLatB(JsgB:JegB)) + cartesian='Y', domain=y_domain, data=gridLatB(JsgB:JegB), edge_axis=.true.) if (use_lonq) & call write_metadata(IO_handle, axis_lonq, name="lonq", units=x_axis_units, longname="Longitude", & - cartesian='X', domain=x_domain, data=gridLonB(IsgB:IegB)) + cartesian='X', domain=x_domain, data=gridLonB(IsgB:IegB), edge_axis=.true.) if (use_layer) & call write_metadata(IO_handle, axis_layer, name="Layer", units=trim(GV%zAxisUnits), & @@ -288,44 +343,82 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim call write_metadata(IO_handle, axis_time, name="Time", units=time_units, longname="Time", cartesian='T') else - call write_metadata(IO_handle, axis_time, name="Time", units="days", longname="Time", cartesian= 'T') + call write_metadata(IO_handle, axis_time, name="Time", units="days", longname="Time", cartesian='T') endif ; endif if (use_periodic) then if (num_periods <= 1) call MOM_error(FATAL, "MOM_io create_file: "//& "num_periods for file "//trim(filename)//" must be at least 1.") ! Define a periodic axis with unit labels. - allocate(period_val(num_periods)) - do k=1,num_periods ; period_val(k) = real(k) ; enddo + allocate(axis_val(num_periods)) + do k=1,num_periods ; axis_val(k) = real(k) ; enddo call write_metadata(IO_handle, axis_periodic, name="Period", units="nondimensional", & - longname="Periods for cyclical varaiables", cartesian='T', data=period_val) - deallocate(period_val) + longname="Periods for cyclical variables", cartesian='T', data=axis_val) + deallocate(axis_val) endif + do m=1,num_extra_dims ; if (use_extra_axis(m)) then + if (allocated(extra_axes(m)%ax_data)) then + call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian, & + sense=extra_axes(m)%sense, data=extra_axes(m)%ax_data) + elseif (trim(extra_axes(m)%cartesian) == "T") then + call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian) + else + ! FMS requires that non-time axes have variables that label their values, even if they are trivial. + allocate (axis_val(extra_axes(m)%ax_size)) + do k=1,extra_axes(m)%ax_size ; axis_val(k) = real(k) ; enddo + call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian, & + sense=extra_axes(m)%sense, data=axis_val) + deallocate(axis_val) + endif + endif ; enddo + do k=1,novars numaxes = 0 - select case (vars(k)%hor_grid) - case ('h') ; numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_lath - case ('q') ; numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_latq - case ('u') ; numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_lath - case ('v') ; numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_latq - case ('T') ; numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_lath - case ('Bu') ; numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_latq - case ('Cu') ; numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_lath - case ('Cv') ; numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_latq - case ('1') ! Do nothing. + position = vars(k)%position + if (position == -1) position = position_from_horgrid(vars(k)%hor_grid) + select case (position) + case (CENTER) + numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_lath ; ax_name(1) = "lonh" ; ax_name(2) = "lath" + case (CORNER) + numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_latq ; ax_name(1) = "lonq" ; ax_name(2) = "latq" + case (EAST_FACE) + numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_lath ; ax_name(1) = "lonq" ; ax_name(2) = "lath" + case (NORTH_FACE) + numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_latq ; ax_name(1) = "lonh" ; ax_name(2) = "latq" + case (0) ! Do nothing. case default call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& - " has unrecognized hor_grid "//trim(vars(k)%hor_grid)) + " has unrecognized position, hor_grid = "//trim(vars(k)%hor_grid)) end select select case (vars(k)%z_grid) - case ('L') ; numaxes = numaxes+1 ; axes(numaxes) = axis_layer - case ('i') ; numaxes = numaxes+1 ; axes(numaxes) = axis_int + case ('L') ; numaxes = numaxes+1 ; axes(numaxes) = axis_layer ; ax_name(numaxes) = "Layer" + case ('i') ; numaxes = numaxes+1 ; axes(numaxes) = axis_int ; ax_name(numaxes) = "Interface" case ('1') ! Do nothing. case default call MOM_error(FATAL, "MOM_io create_file: "//trim(vars(k)%name)//& " has unrecognized z_grid "//trim(vars(k)%z_grid)) end select + + do n=1,numaxes + if ( (len_trim(vars(k)%dim_names(n)) > 0) .and. (trim(ax_name(n)) /= trim(vars(k)%dim_names(n))) ) & + call MOM_error(WARNING, "MOM_io create_file: dimension "//trim(ax_name(n))//& + " of variable "//trim(vars(k)%name)//" in "//trim(filename)//& + " is being set inconsistently as "//trim(vars(k)%dim_names(n))) + enddo + do n=numaxes+1,5 ; if (len_trim(vars(k)%dim_names(n)) > 0) then + dim_found = .false. + do m=1,num_extra_dims + if (lowercase(trim(vars(k)%dim_names(n))) == lowercase(trim(extra_axes(m)%name))) then + numaxes = numaxes+1 ; axes(numaxes) = more_axes(m) + exit + endif + enddo + endif ; enddo + t_grid = adjustl(vars(k)%t_grid) select case (t_grid(1:1)) case ('s', 'a', 'm') ; numaxes = numaxes+1 ; axes(numaxes) = axis_time @@ -346,6 +439,14 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim endif enddo + if (present(global_atts)) then + do n=1,size(global_atts) + if (allocated(global_atts(n)%name) .and. allocated(global_atts(n)%att_val)) & + call write_metadata(IO_handle, global_atts(n)%name, global_atts(n)%att_val) + enddo + endif + + ! Now actualy write the variables with the axis label values if (use_lath) call write_field(IO_handle, axis_lath) if (use_latq) call write_field(IO_handle, axis_latq) if (use_lonh) call write_field(IO_handle, axis_lonh) @@ -353,6 +454,13 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim if (use_layer) call write_field(IO_handle, axis_layer) if (use_int) call write_field(IO_handle, axis_int) if (use_periodic) call write_field(IO_handle, axis_periodic) + do m=1,num_extra_dims ; if (use_extra_axis(m)) then + call write_field(IO_handle, more_axes(m)) + endif ; enddo + + if (num_extra_dims > 0) then + deallocate(use_extra_axis, more_axes) + endif end subroutine create_file @@ -361,7 +469,8 @@ end subroutine create_file !! does not find the file, a new file is created. It also sets up !! structures that describe this file and the variables that will !! later be written to this file. -subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, timeunit, G, dG, GV) +subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & + G, dG, GV, extra_axes, global_atts) type(file_type), intent(inout) :: IO_handle !< Handle for a file or fileset that is to be !! opened or reopened for writing character(len=*), intent(in) :: filename !< full path to the file to create @@ -380,10 +489,14 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is !! required if a new file uses any !! vertical grid axes. + type(axis_info), optional, intent(in) :: extra_axes(:) !< Types with information about + !! some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) !< Global attributes to + !! write to this file type(MOM_domain_type), pointer :: Domain => NULL() character(len=200) :: check_name, mesg - integer :: length, ndim, nvar, natt, ntime, thread + integer :: length, nvar, thread logical :: exists, one_file, domain_set thread = SINGLE_FILE @@ -398,7 +511,7 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim if (.not.exists) then call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & - G=G, dG=dG, GV=GV) + G=G, dG=dG, GV=GV, extra_axes=extra_axes, global_atts=global_atts) else domain_set = .false. @@ -418,13 +531,14 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim endif if (.not.file_is_open(IO_handle)) return - call get_file_info(IO_handle, ndim, nvar, natt, ntime) + call get_file_info(IO_handle, nvar=nvar) if (nvar == -1) then write (mesg,*) "Reopening file ",trim(filename)," apparently had ",nvar,& " variables. Clobbering and creating file with ",novars," instead." call MOM_error(WARNING,"MOM_io: "//mesg) - call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, G=G, GV=GV) + call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & + G=G, dG=dG, GV=GV, extra_axes=extra_axes, global_atts=global_atts) elseif (nvar /= novars) then write (mesg,*) "Reopening file ",trim(filename)," with ",novars,& " variables instead of ",nvar,"." @@ -1197,21 +1311,29 @@ end subroutine verify_variable_units !! fields. The argument name is required, while the others are optional and !! have default values that are empty strings or are appropriate for a 3-d !! tracer field at the tracer cell centers. -function var_desc(name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, cmor_longname, conversion, caller) result(vd) - character(len=*), intent(in) :: name !< variable name - character(len=*), optional, intent(in) :: units !< variable units - character(len=*), optional, intent(in) :: longname !< variable long name - character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering - character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering - character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 - character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name - character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable - character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name - real , optional, intent(in) :: conversion !< for unit conversions, such as needed to - !! convert from intensive to extensive - character(len=*), optional, intent(in) :: caller !< calling routine? - type(vardesc) :: vd !< vardesc type that is created +function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_name, & + cmor_units, cmor_longname, conversion, caller, position, dim_names, fixed) result(vd) + character(len=*), intent(in) :: name !< variable name + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: hor_grid !< A character string indicating the horizontal + !! position of this variable + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name + character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name + real , optional, intent(in) :: conversion !< for unit conversions, such as needed to + !! convert from intensive to extensive + character(len=*), optional, intent(in) :: caller !< The calling routine for error messages + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal position + !! of this variable if it has such dimensions. + !! Valid values include CORNER, CENTER, EAST_FACE + !! NORTH_FACE, and 0 for no horizontal dimensions. + character(len=*), dimension(:), & + optional, intent(in) :: dim_names !< The names of the dimensions of this variable + logical, optional, intent(in) :: fixed !< If true, this does not evolve with time + type(vardesc) :: vd !< vardesc type that is created character(len=120) :: cllr cllr = "var_desc" @@ -1220,15 +1342,18 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, & call safe_string_copy(name, vd%name, "vd%name", cllr) vd%longname = "" ; vd%units = "" - vd%hor_grid = 'h' ; vd%z_grid = 'L' ; vd%t_grid = 's' + vd%hor_grid = 'h' ; vd%position = CENTER ; vd%z_grid = 'L' ; vd%t_grid = 's' + if (present(dim_names)) vd%z_grid = '1' ! In this case the names are used to set the non-horizontal axes + if (present(fixed)) then ; if (fixed) vd%t_grid = '1' ; endif vd%cmor_field_name = "" vd%cmor_units = "" vd%cmor_longname = "" vd%conversion = 1.0 + vd%dim_names(:) = "" call modify_vardesc(vd, units=units, longname=longname, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid, & + z_grid=z_grid, t_grid=t_grid, position=position, dim_names=dim_names, & cmor_field_name=cmor_field_name, cmor_units=cmor_units, & cmor_longname=cmor_longname, conversion=conversion, caller=cllr) @@ -1238,7 +1363,7 @@ end function var_desc !> This routine modifies the named elements of a vardesc type. !! All arguments are optional, except the vardesc type to be modified. subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, cmor_longname, conversion, caller) + cmor_field_name, cmor_units, cmor_longname, conversion, caller, position, dim_names) type(vardesc), intent(inout) :: vd !< vardesc type that is modified character(len=*), optional, intent(in) :: name !< name of variable character(len=*), optional, intent(in) :: units !< units of variable @@ -1249,13 +1374,21 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name - real , optional, intent(in) :: conversion !< for unit conversions, such as needed - !! to convert from intensive to extensive - character(len=*), optional, intent(in) :: caller !< calling routine? + real , optional, intent(in) :: conversion !< A multiplicative factor for unit conversions, + !! such as needed to convert from intensive to + !! extensive or dimensional consistency testing + character(len=*), optional, intent(in) :: caller !< The calling routine for error messages + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal position + !! of this variable if it has such dimensions. + !! Valid values include CORNER, CENTER, EAST_FACE + !! NORTH_FACE, and 0 for no horizontal dimensions. + character(len=*), dimension(:), & + optional, intent(in) :: dim_names !< The names of the dimensions of this variable character(len=120) :: cllr - cllr = "mod_vardesc" - if (present(caller)) cllr = trim(caller) + integer :: n + + cllr = "mod_vardesc" ; if (present(caller)) cllr = trim(caller) if (present(name)) call safe_string_copy(name, vd%name, "vd%name", cllr) @@ -1263,8 +1396,28 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & "vd%longname of "//trim(vd%name), cllr) if (present(units)) call safe_string_copy(units, vd%units, & "vd%units of "//trim(vd%name), cllr) - if (present(hor_grid)) call safe_string_copy(hor_grid, vd%hor_grid, & - "vd%hor_grid of "//trim(vd%name), cllr) + if (present(position)) then + vd%position = position + select case (position) + case (CENTER) ; vd%hor_grid = 'T' + case (CORNER) ; vd%hor_grid = 'Bu' + case (EAST_FACE) ; vd%hor_grid = 'Cu' + case (NORTH_FACE) ; vd%hor_grid = 'Cv' + case (0) ; vd%hor_grid = '1' + case default + call MOM_error(FATAL, "modify_vardesc: "//trim(vd%name)//" has unrecognized position argument") + end select + endif + if (present(hor_grid)) then + call safe_string_copy(hor_grid, vd%hor_grid, "vd%hor_grid of "//trim(vd%name), cllr) + vd%position = position_from_horgrid(vd%hor_grid) + if (present(caller) .and. (vd%position == -1)) then + call MOM_error(FATAL, "modify_vardesc called by "//trim(caller)//": "//trim(vd%name)//& + " has an unrecognized hor_grid argument "//trim(vd%hor_grid)) + elseif (vd%position == -1) then + call MOM_error(FATAL, "modify_vardesc called with bad hor_grid argument "//trim(vd%hor_grid)) + endif + endif if (present(z_grid)) call safe_string_copy(z_grid, vd%z_grid, & "vd%z_grid of "//trim(vd%name), cllr) if (present(t_grid)) call safe_string_copy(t_grid, vd%t_grid, & @@ -1277,8 +1430,110 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & if (present(cmor_longname)) call safe_string_copy(cmor_longname, vd%cmor_longname, & "vd%cmor_longname of "//trim(vd%name), cllr) + if (present(dim_names)) then + do n=1,min(5,size(dim_names)) ; if (len_trim(dim_names(n)) > 0) then + call safe_string_copy(dim_names(n), vd%dim_names(n), "vd%dim_names of "//trim(vd%name), cllr) + endif ; enddo + endif + end subroutine modify_vardesc +integer function position_from_horgrid(hor_grid) + character(len=*), intent(in) :: hor_grid !< horizontal staggering of variable + + select case (trim(hor_grid)) + case ('h') ; position_from_horgrid = CENTER + case ('q') ; position_from_horgrid = CORNER + case ('u') ; position_from_horgrid = EAST_FACE + case ('v') ; position_from_horgrid = NORTH_FACE + case ('T') ; position_from_horgrid = CENTER + case ('Bu') ; position_from_horgrid = CORNER + case ('Cu') ; position_from_horgrid = EAST_FACE + case ('Cv') ; position_from_horgrid = NORTH_FACE + case ('1') ; position_from_horgrid = 0 + case default ; position_from_horgrid = -1 ! This is a bad-value flag. + end select +end function position_from_horgrid + +!> Store information that can be used to create an axis in a subsequent call to create_file. +subroutine set_axis_info(axis, name, units, longname, ax_size, ax_data, cartesian, sense) + type(axis_info), intent(inout) :: axis !< A type with information about a named axis + character(len=*), intent(in) :: name !< The name of this axis for use in files + character(len=*), optional, intent(in) :: units !< The units of the axis labels + character(len=*), optional, intent(in) :: longname !< Long name of the axis variable + integer, optional, intent(in) :: ax_size !< The number of elements in this axis + real, dimension(:), optional, intent(in) :: ax_data !< The values of the data on the axis + character(len=*), optional, intent(in) :: cartesian !< A variable indicating which direction this axis + !! axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' (the default) for none. + integer, optional, intent(in) :: sense !< This is 1 for axes whose values increase upward, or -1 + !! if they increase downward. The default, 0, is ignored. + + call safe_string_copy(name, axis%name, "axis%name of "//trim(name), "set_axis_info") + ! Set the default values. + axis%longname = trim(axis%name) ; axis%units = "" ; axis%cartesian = "N" ; axis%sense = 0 + + if (present(longname)) call safe_string_copy(longname, axis%longname, & + "axis%longname of "//trim(name), "set_axis_info") + if (present(units)) call safe_string_copy(units, axis%units, & + "axis%units of "//trim(name), "set_axis_info") + if (present(cartesian)) call safe_string_copy(cartesian, axis%cartesian, & + "axis%cartesian of "//trim(name), "set_axis_info") + if (present(sense)) axis%sense = sense + + if (.not.(present(ax_size) .or. present(ax_data)) ) then + call MOM_error(FATAL, "set_axis_info called for "//trim(name)//& + "without either an ax_size or an ax_data argument.") + elseif (present(ax_size) .and. present(ax_data)) then + if (size(ax_data) /= ax_size) call MOM_error(FATAL, "set_axis_info called for "//trim(name)//& + "with an inconsistent value of ax_size and size of ax_data.") + endif + + if (present(ax_size)) then + axis%ax_size = ax_size + else + axis%ax_size = size(ax_data) + endif + if (present(ax_data)) then + allocate(axis%ax_data(axis%ax_size)) ; axis%ax_data(:) = ax_data(:) + endif + +end subroutine set_axis_info + +!> Delete the information in an array of axis_info types and deallocate memory in them. +subroutine delete_axis_info(axes) + type(axis_info), dimension(:), intent(inout) :: axes !< An array with information about named axes + + integer :: n + do n=1,size(axes) + axes(n)%name = "" ; axes(n)%longname = "" ; axes(n)%units = "" ; axes(n)%cartesian = "N" + axes(n)%sense = 0 ; axes(n)%ax_size = 0 + if (allocated(axes(n)%ax_data)) deallocate(axes(n)%ax_data) + enddo +end subroutine delete_axis_info + +!> Store information that can be used to create an attribute in a subsequent call to create_file. +subroutine set_attribute_info(attribute, name, str_value) + type(attribute_info), intent(inout) :: attribute !< A type with information about a named attribute + character(len=*), intent(in) :: name !< The name of this attribute for use in files + character(len=*), intent(in) :: str_value !< The value of this attribute + + attribute%name = trim(name) + attribute%att_val = trim(str_value) +end subroutine set_attribute_info + +!> Delete the information in an array of attribute_info types and deallocate memory in them. +subroutine delete_attribute_info(atts) + type(attribute_info), dimension(:), intent(inout) :: atts !< An array of global attributes + + integer :: n + do n=1,size(atts) + if (allocated(atts(n)%name)) deallocate(atts(n)%name) + if (allocated(atts(n)%att_val)) deallocate(atts(n)%att_val) + enddo +end subroutine delete_attribute_info + + !> This function returns the CMOR standard name given a CMOR longname, based on !! the standard pattern of character conversions. function cmor_long_std(longname) result(std_name) @@ -1297,7 +1552,8 @@ end function cmor_long_std !> This routine queries vardesc subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, cmor_longname, conversion, caller) + cmor_field_name, cmor_units, cmor_longname, conversion, caller, & + position, dim_names) type(vardesc), intent(in) :: vd !< vardesc type that is queried character(len=*), optional, intent(out) :: name !< name of variable character(len=*), optional, intent(out) :: units !< units of variable @@ -1311,8 +1567,14 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & real , optional, intent(out) :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive character(len=*), optional, intent(in) :: caller !< calling routine? + integer, optional, intent(out) :: position !< A coded integer indicating the horizontal position + !! of this variable if it has such dimensions. + !! Valid values include CORNER, CENTER, EAST_FACE + !! NORTH_FACE, and 0 for no horizontal dimensions. + character(len=*), dimension(:), & + optional, intent(out) :: dim_names !< The names of the dimensions of this variable - + integer :: n character(len=120) :: cllr cllr = "mod_vardesc" if (present(caller)) cllr = trim(caller) @@ -1336,6 +1598,15 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & "vd%cmor_units of "//trim(vd%name), cllr) if (present(cmor_longname)) call safe_string_copy(vd%cmor_longname, cmor_longname, & "vd%cmor_longname of "//trim(vd%name), cllr) + if (present(position)) then + position = vd%position + if (position == -1) position = position_from_horgrid(vd%hor_grid) + endif + if (present(dim_names)) then + do n=1,min(5,size(dim_names)) + call safe_string_copy(vd%dim_names(n), dim_names(n), "vd%dim_names of "//trim(vd%name), cllr) + enddo + endif end subroutine query_vardesc @@ -1343,7 +1614,7 @@ end subroutine query_vardesc !> Write a 4d field to an output file, potentially with rotation subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write @@ -1378,7 +1649,7 @@ end subroutine MOM_write_field_4d !> Write a 3d field to an output file, potentially with rotation subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write @@ -1413,7 +1684,7 @@ end subroutine MOM_write_field_3d !> Write a 2d field to an output file, potentially with rotation subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:), intent(inout) :: field !< Unrotated field to write @@ -1447,7 +1718,7 @@ end subroutine MOM_write_field_2d !> Write a 1d field to an output file subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, dimension(:), intent(in) :: field !< Field to write real, optional, intent(in) :: tstamp !< Model timestamp @@ -1476,7 +1747,7 @@ end subroutine MOM_write_field_1d !> Write a 0d field to an output file subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, intent(in) :: field !< Field to write real, optional, intent(in) :: tstamp !< Model timestamp @@ -1672,6 +1943,4 @@ end subroutine MOM_io_init !! !! * handle_error: write an error code and quit. - - end module MOM_io diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 0625177d77..129f52ad4c 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -131,7 +131,8 @@ module MOM_restart end interface contains -!!> Register a restart field as obsolete + +!> Register a restart field as obsolete subroutine register_restart_field_as_obsolete(field_name, replacement_name, CS) character(*), intent(in) :: field_name !< Name of restart field that is no longer in use character(*), intent(in) :: replacement_name !< Name of replacement restart field, if applicable @@ -499,8 +500,6 @@ function query_initialized_name(name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine returns .true. if the field referred to by name has -! initialized from a restart file, and .false. otherwise. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -515,8 +514,7 @@ function query_initialized_name(name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if ((n==CS%novars+1) .and. (is_root_pe())) & call MOM_error(NOTE,"MOM_restart: Unknown restart variable "//name// & @@ -533,8 +531,6 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr has -! been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -549,8 +545,7 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_0d @@ -560,8 +555,6 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr has -! been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -576,8 +569,7 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_1d @@ -588,8 +580,6 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) target, intent(in) :: f_ptr !< A pointer to the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr has -! been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -604,8 +594,7 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_2d @@ -616,8 +605,6 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) target, intent(in) :: f_ptr !< A pointer to the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr has -! been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -632,8 +619,7 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_3d @@ -644,8 +630,6 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) target, intent(in) :: f_ptr !< A pointer to the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr has -! been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -660,8 +644,7 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_4d @@ -673,8 +656,6 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr or with the -! specified variable name has been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -689,8 +670,7 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & @@ -709,8 +689,6 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr or with the -! specified variable name has been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -725,8 +703,7 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & @@ -745,8 +722,6 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr or with the -! specified variable name has been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -761,8 +736,7 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & @@ -781,8 +755,6 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr or with the -! specified variable name has been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -797,8 +769,7 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & @@ -817,8 +788,6 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr or with the -! specified variable name has been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -833,8 +802,7 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & @@ -846,23 +814,27 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_4d_name !> save_restart saves all registered variables to restart files. -subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_rest_files) +subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_rest_files, write_IC) character(len=*), intent(in) :: directory !< The directory where the restart files !! are to be written type(time_type), intent(in) :: time !< The current model time type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous - !! call to restart_init. - logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp - !! to the restart file names. - character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile. - type(verticalGrid_type), optional, intent(in) :: GV !< The ocean's vertical grid structure - integer, optional, intent(out) :: num_rest_files !< number of restart files written + !! call to restart_init + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp + !! to the restart file names + character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile + type(verticalGrid_type), & + optional, intent(in) :: GV !< The ocean's vertical grid structure + integer, optional, intent(out) :: num_rest_files !< number of restart files written + logical, optional, intent(in) :: write_IC !< If present and true, initial conditions + !! are being written ! Local variables type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that ! are to be read from the restart file. - type(fieldtype) :: fields(CS%max_fields) ! + type(fieldtype) :: fields(CS%max_fields) ! Opaque types containing metadata describing + ! each variable that will be written. character(len=512) :: restartpath ! The restart file path (dir/file). character(len=256) :: restartname ! The restart file name (no dir). character(len=8) :: suffix ! A suffix (like _2) that is appended @@ -875,13 +847,12 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer :: start_var, next_var ! The starting variables of the ! current and next files. type(file_type) :: IO_handle ! The I/O handle of the open fileset - integer :: m, nz, num_files, var_periods + integer :: m, nz, num_files integer :: seconds, days, year, month, hour, minute character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. - character(len=8) :: t_grid_read character(len=64) :: var_name ! A variable's name. real :: restart_time - character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs + character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs integer :: length integer(kind=8) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos @@ -931,24 +902,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ do m=start_var,CS%novars call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid, caller="save_restart") - if (hor_grid == '1') then - var_sz = 8 - else - var_sz = 8*(G%Domain%niglobal+1)*(G%Domain%njglobal+1) - endif - select case (z_grid) - case ('L') ; var_sz = var_sz * nz - case ('i') ; var_sz = var_sz * (nz+1) - end select - t_grid = adjustl(t_grid) - if (t_grid(1:1) == 'p') then - if (len_trim(t_grid(2:8)) > 0) then - var_periods = -1 - t_grid_read = adjustl(t_grid(2:8)) - read(t_grid_read,*) var_periods - if (var_periods > 1) var_sz = var_sz * var_periods - endif - endif + var_sz = get_variable_byte_size(hor_grid, z_grid, t_grid, G, nz) if ((m==start_var) .OR. (size_in_file < max_file_size-var_sz)) then size_in_file = size_in_file + var_sz @@ -958,7 +912,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ enddo next_var = m - !query fms_io if there is a filename_appendix (for ensemble runs) + ! Determine if there is a filename_appendix (used for ensemble runs). call get_filename_appendix(filename_appendix) if (len_trim(filename_appendix) > 0) then length = len_trim(restartname) @@ -1059,20 +1013,16 @@ end subroutine save_restart !! in which they are found. subroutine restore_state(filename, directory, day, G, CS) character(len=*), intent(in) :: filename !< The list of restart file names or a single - !! character 'r' to read automatically named files. + !! character 'r' to read automatically named files character(len=*), intent(in) :: directory !< The directory in which to find restart files type(time_type), intent(out) :: day !< The time of the restarted run type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous - !! call to restart_init. - -! This subroutine reads the model state from previously -! generated files. All restart variables are read from the first -! file in the input filename list in which they are found. + !! call to restart_init ! Local variables character(len=200) :: filepath ! The path (dir/file) to the file being opened. - character(len=80) :: fname ! The name of the current file. + character(len=80) :: fname ! The name of the current file. character(len=8) :: suffix ! A suffix (like "_2") that is added to any ! additional restart files. character(len=512) :: mesg ! A message for warnings. @@ -1100,7 +1050,7 @@ subroutine restore_state(filename, directory, day, G, CS) "restore_state: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) -! Get NetCDF ids for all of the restart files. + ! Get NetCDF ids for all of the restart files. if ((LEN_TRIM(filename) == 1) .and. (filename(1:1) == 'F')) then num_file = open_restart_units('r', directory, G, CS, IO_handles=IO_handles, & file_paths=unit_path, global_files=unit_is_global) @@ -1115,7 +1065,7 @@ subroutine restore_state(filename, directory, day, G, CS) call MOM_error(FATAL,"MOM_restart: "//mesg) endif -! Get the time from the first file in the list that has one. + ! Get the time from the first file in the list that has one. do n=1,num_file call get_file_times(IO_handles(n), time_vals, ntime) if (ntime < 1) cycle @@ -1130,8 +1080,8 @@ subroutine restore_state(filename, directory, day, G, CS) if (n>num_file) call MOM_error(WARNING,"MOM_restart: " // & "No times found in restart files.") -! Check the remaining files for different times and issue a warning -! if they differ from the first time. + ! Check the remaining files for different times and issue a warning + ! if they differ from the first time. if (is_root_pe()) then do m = n+1,num_file call get_file_times(IO_handles(n), time_vals, ntime) @@ -1149,7 +1099,7 @@ subroutine restore_state(filename, directory, day, G, CS) enddo endif -! Read each variable from the first file in which it is found. + ! Read each variable from the first file in which it is found. do n=1,num_file call get_file_info(IO_handles(n), nvar=nvar) @@ -1263,7 +1213,7 @@ subroutine restore_state(filename, directory, day, G, CS) call close_file(IO_handles(n)) enddo -! Check whether any mandatory fields have not been found. + ! Check whether any mandatory fields have not been found. CS%restart = .true. do m=1,CS%novars if (.not.(CS%restart_field(m)%initialized)) then @@ -1280,23 +1230,23 @@ end subroutine restore_state !> restart_files_exist determines whether any restart files exist. function restart_files_exist(filename, directory, G, CS) character(len=*), intent(in) :: filename !< The list of restart file names or a single - !! character 'r' to read automatically named files. + !! character 'r' to read automatically named files character(len=*), intent(in) :: directory !< The directory in which to find restart files type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous - !! call to restart_init. + !! call to restart_init logical :: restart_files_exist !< The function result, which indicates whether !! any of the explicitly or automatically named - !! restart files exist in directory. + !! restart files exist in directory integer :: num_files if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "restart_files_exist: Module must be initialized before it is used.") if ((LEN_TRIM(filename) == 1) .and. (filename(1:1) == 'F')) then - num_files = open_restart_units('r', directory, G, CS) + num_files = get_num_restart_files('r', directory, G, CS) else - num_files = open_restart_units(filename, directory, G, CS) + num_files = get_num_restart_files(filename, directory, G, CS) endif restart_files_exist = (num_files > 0) @@ -1307,14 +1257,14 @@ end function restart_files_exist !! and as a side effect stores this information in CS. function determine_is_new_run(filename, directory, G, CS) result(is_new_run) character(len=*), intent(in) :: filename !< The list of restart file names or a single - !! character 'r' to read automatically named files. + !! character 'r' to read automatically named files character(len=*), intent(in) :: directory !< The directory in which to find restart files type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous - !! call to restart_init. + !! call to restart_init logical :: is_new_run !< The function result, which indicates whether !! this is a new run, based on the value of - !! filename and whether restart files exist. + !! filename and whether restart files exist if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "determine_is_new_run: Module must be initialized before it is used.") @@ -1325,7 +1275,7 @@ function determine_is_new_run(filename, directory, G, CS) result(is_new_run) elseif (filename(1:1) == 'n') then CS%new_run = .true. elseif (filename(1:1) == 'F') then - CS%new_run = (open_restart_units('r', directory, G, CS) == 0) + CS%new_run = (get_num_restart_files('r', directory, G, CS) == 0) else CS%new_run = .false. endif @@ -1338,10 +1288,9 @@ end function determine_is_new_run !! information stored in CS by a previous call to determine_is_new_run. function is_new_run(CS) type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous - !! call to restart_init. - logical :: is_new_run !< The function result, which indicates whether - !! this is a new run, based on the value of - !! filename and whether restart files exist. + !! call to restart_init + logical :: is_new_run !< The function result, which had been stored in CS during + !! a previous call to determine_is_new_run if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "is_new_run: Module must be initialized before it is used.") @@ -1356,47 +1305,42 @@ end function is_new_run function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, & global_files) result(num_files) character(len=*), intent(in) :: filename !< The list of restart file names or a single - !! character 'r' to read automatically named files. + !! character 'r' to read automatically named files character(len=*), intent(in) :: directory !< The directory in which to find restart files type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous - !! call to restart_init. + !! call to restart_init type(file_type), dimension(:), & - optional, intent(out) :: IO_handles !< The I/O handles of all opened files. + optional, intent(out) :: IO_handles !< The I/O handles of all opened files character(len=*), dimension(:), & - optional, intent(out) :: file_paths !< The full paths to open files. + optional, intent(out) :: file_paths !< The full paths to open files logical, dimension(:), & - optional, intent(out) :: global_files !< True if a file is global. + optional, intent(out) :: global_files !< True if a file is global integer :: num_files !< The number of files (both automatically named restart !! files and others explicitly in filename) that have been opened. -! This subroutine reads the model state from previously -! generated files. All restart variables are read from the first -! file in the input filename list in which they are found. - ! Local variables character(len=256) :: filepath ! The path (dir/file) to the file being opened. character(len=256) :: fname ! The name of the current file. character(len=8) :: suffix ! A suffix (like "_2") that is added to any ! additional restart files. -! character(len=256) :: mesg ! A message for warnings. integer :: num_restart ! The number of restart files that have already - ! been opened. + ! been opened using their numbered suffix. integer :: start_char ! The location of the starting character in the ! current file name. - integer :: n, m, err, length - - - logical :: fexists - character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs + integer :: nf ! The number of files that have been found so far + integer :: m, length + logical :: still_looking ! If true, the code is still looking for automatically named files + logical :: fexists ! True if a file has been found + character(len=32) :: filename_appendix = '' ! Filename appendix for ensemble runs character(len=80) :: restartname if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "open_restart_units: Module must be initialized before it is used.") -! Get NetCDF ids for all of the restart files. - num_restart = 0 ; n = 1 ; start_char = 1 + ! Get NetCDF ids for all of the restart files. + num_restart = 0 ; nf = 0 ; start_char = 1 do while (start_char <= len_trim(filename) ) do m=start_char,len_trim(filename) if (filename(m:m) == ' ') exit @@ -1412,12 +1356,11 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, enddo if ((fname(1:1)=='r') .and. ( len_trim(fname) == 1)) then - err = 0 - if (num_restart > 0) err = 1 ! Avoid going through the file list twice. - do while (err == 0) + still_looking = (num_restart <= 0) ! Avoid going through the file list twice. + do while (still_looking) restartname = trim(CS%restartfile) - ! query fms_io if there is a filename_appendix (for ensemble runs) + ! Determine if there is a filename_appendix (used for ensemble runs). call get_filename_appendix(filename_appendix) if (len_trim(filename_appendix) > 0) then length = len_trim(restartname) @@ -1436,33 +1379,37 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, endif if (num_restart > 0) filepath = trim(filepath) // suffix - ! if (.not.file_exists(filepath)) & - filepath = trim(filepath)//".nc" + filepath = trim(filepath)//".nc" num_restart = num_restart + 1 + ! Look for a global netCDF file. inquire(file=filepath, exist=fexists) if (fexists) then + nf = nf + 1 if (present(IO_handles)) & - call open_file(IO_handles(n), trim(filepath), READONLY_FILE, & + call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) - if (present(global_files)) global_files(n) = .true. + if (present(global_files)) global_files(nf) = .true. + if (present(file_paths)) file_paths(nf) = filepath elseif (CS%parallel_restartfiles) then ! Look for decomposed files using the I/O Layout. fexists = file_exists(filepath, G%Domain) - if (fexists .and. (present(IO_handles))) & - call open_file(IO_handles(n), trim(filepath), READONLY_FILE, MOM_domain=G%Domain) - if (fexists .and. present(global_files)) global_files(n) = .false. + if (fexists) then + nf = nf + 1 + if (present(IO_handles)) & + call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, MOM_domain=G%Domain) + if (present(global_files)) global_files(nf) = .false. + if (present(file_paths)) file_paths(nf) = filepath + endif endif if (fexists) then - if (present(file_paths)) file_paths(n) = filepath - n = n + 1 if (is_root_pe() .and. (present(IO_handles))) & call MOM_error(NOTE, "MOM_restart: MOM run restarted using : "//trim(filepath)) else - err = 1 ; exit + still_looking = .false. ; exit endif - enddo ! while (err == 0) loop + enddo ! while (still_looking) loop else filepath = trim(directory)//trim(fname) inquire(file=filepath, exist=fexists) @@ -1470,12 +1417,12 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, inquire(file=filepath, exist=fexists) if (fexists) then + nf = nf + 1 if (present(IO_handles)) & - call open_file(IO_handles(n), trim(filepath), READONLY_FILE, & + call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) - if (present(global_files)) global_files(n) = .true. - if (present(file_paths)) file_paths(n) = filepath - n = n + 1 + if (present(global_files)) global_files(nf) = .true. + if (present(file_paths)) file_paths(nf) = filepath if (is_root_pe() .and. (present(IO_handles))) & call MOM_error(NOTE,"MOM_restart: MOM run restarted using : "//trim(filepath)) else @@ -1484,11 +1431,36 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, endif endif - enddo ! while (start_char < strlen(filename)) loop - num_files = n-1 + enddo ! while (start_char < len_trim(filename)) loop + num_files = nf end function open_restart_units +!> get_num_restart_files returns the number of existing restart files that match the provided +!! directory structure and other information stored in the control structure and optionally +!! also provides the full paths to these files. +function get_num_restart_files(filenames, directory, G, CS, file_paths) result(num_files) + character(len=*), intent(in) :: filenames !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), intent(in) :: directory !< The directory in which to find restart files + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous + !! call to restart_init + character(len=*), dimension(:), & + optional, intent(out) :: file_paths !< The full paths to the restart files. + integer :: num_files !< The function result, the number of files (both automatically named + !! restart files and others explicitly in filename) that have been opened + + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & + "get_num_restart_files: Module must be initialized before it is used.") + + ! This call uses open_restart_units without the optional arguments needed to actually + ! open the files to determine the number of restart files. + num_files = open_restart_units(filenames, directory, G, CS, file_paths=file_paths) + +end function get_num_restart_files + + !> Initialize this module and set up a restart control structure. subroutine restart_init(param_file, CS, restart_root) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters @@ -1642,4 +1614,40 @@ subroutine get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) end subroutine get_checksum_loop_ranges +!> get the size of a variable in bytes +function get_variable_byte_size(hor_grid, z_grid, t_grid, G, num_z) result(var_sz) + character(len=8), intent(in) :: hor_grid !< The horizontal grid string to interpret + character(len=8), intent(in) :: z_grid !< The vertical grid string to interpret + character(len=8), intent(in) :: t_grid !< A time string to interpret + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: num_z !< The number of vertical layers in the grid + integer(kind=8) :: var_sz !< The function result, the size in bytes of a variable + + ! Local variables + integer :: var_periods ! The number of entries in a time-periodic axis + character(len=8) :: t_grid_read, t_grid_tmp ! Modified versions of t_grid + + if (trim(hor_grid) == '1') then + var_sz = 8 + else ! This may be an overestimate, as it is based on symmetric-memory corner points. + var_sz = 8*(G%Domain%niglobal+1)*(G%Domain%njglobal+1) + endif + + select case (trim(z_grid)) + case ('L') ; var_sz = var_sz * num_z + case ('i') ; var_sz = var_sz * (num_z+1) + end select + + t_grid_tmp = adjustl(t_grid) + if (t_grid_tmp(1:1) == 'p') then + if (len_trim(t_grid_tmp(2:8)) > 0) then + var_periods = -1 + t_grid_read = adjustl(t_grid_tmp(2:8)) + read(t_grid_read,*) var_periods + if (var_periods > 1) var_sz = var_sz * var_periods + endif + endif + +end function get_variable_byte_size + end module MOM_restart diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 5c04a77b7d..ddc1b41290 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -17,6 +17,7 @@ module MOM_string_functions public extract_real public remove_spaces public slasher +public append_substring contains @@ -418,6 +419,34 @@ function slasher(dir) endif end function slasher +!> append a string (substring) to another string (string_in) and return the +!! concatenated string (string_out) +function append_substring(string_in, substring) result(string_out) + character(len=*), intent(in) :: string_in !< input string + character(len=*), intent(in) :: substring !< string to append string_in + ! local + character(len=1024) :: string_out + character(len=1024) :: string_joined + integer :: string_in_length + integer :: substring_length + + string_out = '' + string_joined = '' + string_in_length = 0 + substring_length = 0 + + string_in_length = len_trim(string_in) + substring_length = len_trim(substring) + + if (string_in_length > 0) then + if (substring_length > 0) then + string_joined = trim(string_in)//trim(substring) + string_out(1:len_trim(string_joined)) = trim(string_joined) + endif + endif + +end function append_substring + !> \namespace mom_string_functions !! !! By Alistair Adcroft and Robert Hallberg, last updated Sept. 2013. diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d6390c9453..488269e974 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -722,6 +722,17 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) endif endif + ! Melting has been computed, now is time to update thickness and mass with dynamic ice shelf + if (CS%active_shelf_dynamics) then + call change_thickness_using_melt(ISS, G, US, US%s_to_T*time_step, fluxes, CS%density_ice, CS%debug) + + if (CS%debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2) + endif + endif + if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) call add_shelf_flux(G, US, CS, sfc_state, fluxes) @@ -1641,8 +1652,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, elseif (.not.new_sim) then ! This line calls a subroutine that reads the initial conditions from a restart file. call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & - G, CS%restart_CSp) + call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, G, CS%restart_CSp) if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then Z_rescale = US%m_to_Z / US%m_to_Z_restart @@ -1752,16 +1762,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call fix_restart_unit_scaling(US) call get_param(param_file, mdl, "SAVE_INITIAL_CONDS", save_IC, & - "If true, save the ice shelf initial conditions.", & - default=.false.) + "If true, save the ice shelf initial conditions.", default=.false.) if (save_IC) call get_param(param_file, mdl, "SHELF_IC_OUTPUT_FILE", IC_file,& - "The name-root of the output file for the ice shelf "//& - "initial conditions.", default="MOM_Shelf_IC") + "The name-root of the output file for the ice shelf initial conditions.", & + default="MOM_Shelf_IC") if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1))) then - call save_restart(dirs%output_directory, CS%Time, CS%Grid_in, & - CS%restart_CSp, filename=IC_file) + call save_restart(dirs%output_directory, CS%Time, CS%Grid_in, CS%restart_CSp, & + filename=IC_file, write_ic=.true.) endif diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index a70ae45137..cf6845599b 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -24,6 +24,7 @@ module MOM_ice_shelf_dynamics use MOM_ice_shelf_state, only : ice_shelf_state use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs use MOM_checksums, only : hchksum, qchksum +use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_channel,initialize_ice_flow_from_file implicit none ; private @@ -44,7 +45,10 @@ module MOM_ice_shelf_dynamics !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet !! on q-points (B grid) [L T-1 ~> m s-1] - + real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the driving stress of the ice shelf/sheet + !! on q-points (C grid) [Pa ~> Pa] + real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional stress of the ice shelf/sheet + !! on q-points (C grid) [Pa ~> Pa] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, !! not vertices. Will represent boundary conditions on computational boundary @@ -152,12 +156,14 @@ module MOM_ice_shelf_dynamics !>@{ Diagnostic handles integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & + id_taudx_shelf = -1, id_taudy_shelf = -1, & id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, & id_u_mask = -1, id_v_mask = -1, id_t_mask = -1 !>@} ! ids for outputting intermediate thickness in advection subroutine (debugging) - !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 - + !>@{ Diagnostic handles for debugging + integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1, id_visc_shelf = -1 + !>@} type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. end type ice_shelf_dyn_CS @@ -250,7 +256,8 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) allocate( CS%basal_traction(isd:ied,jsd:jed) ) ; CS%basal_traction(:,:) = 0.0 allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 allocate( CS%ground_frac(isd:ied,jsd:jed) ) ; CS%ground_frac(:,:) = 0.0 - + allocate( CS%taudx_shelf(Isd:Ied,Jsd:Jed) ) ; CS%taudx_shelf(:,:) = 0.0 + allocate( CS%taudy_shelf(Isd:Ied,Jsd:Jed) ) ; CS%taudy_shelf(:,:) = 0.0 ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & "ice sheet/shelf u-velocity", "m s-1", hor_grid='Bu') @@ -258,6 +265,10 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) "ice sheet/shelf v-velocity", "m s-1", hor_grid='Bu') call register_restart_field(CS%t_shelf, "t_shelf", .true., restart_CS, & "ice sheet/shelf vertically averaged temperature", "deg C") + call register_restart_field(CS%taudx_shelf, "taudx_shelf", .true., restart_CS, & + "ice sheet/shelf taudx-driving stress", "kPa") + call register_restart_field(CS%taudy_shelf, "taudy_shelf", .true., restart_CS, & + "ice sheet/shelf taudy-driving stress", "kPa") call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & "Average open ocean depth in a cell","m") call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & @@ -367,20 +378,20 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & "Ice viscosity parameter in Glen's Law", & - units="Pa-3 yr-1", default=9.461e-18, scale=1.0/(365.0*86400.0)) + units="Pa-3 s-1", default=2.2261e-25, scale=1.0) ! This default is equivalent to 3.0001e-25 Pa-3 s-1, appropriate at about -10 C. call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & "nonlinearity exponent in Glen's Law", & units="none", default=3.) call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", CS%eps_glen_min, & "min. strain rate to avoid infinite Glen's law viscosity", & - units="a-1", default=1.e-12, scale=US%T_to_s/(365.0*86400.0)) + units="s-1", default=1.e-19, scale=US%T_to_s) call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_fric, & "Exponent in sliding law \tau_b = C u^(n_basal_fric)", & units="none", fail_if_missing=.true.) call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & "Coefficient in sliding law \tau_b = C u^(n_basal_fric)", & - units="Pa (m yr-1)-(n_basal_fric)", scale=US%kg_m2s_to_RZ_T*((365.0*86400.0)**CS%n_basal_fric), & + units="Pa (m s-1)^(n_basal_fric)", scale=US%kg_m2s_to_RZ_T**CS%n_basal_fric, & fail_if_missing=.true.) call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) @@ -400,10 +411,11 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & "Specify whether to advance shelf front (and calve).", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & "If true, do not allow an ice shelf where prohibited by a mask.", & default=.false.) + endif call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", CS%min_thickness_simple_calve, & "Min thickness rule for the VERY simple calving law",& @@ -411,10 +423,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Allocate memory in the ice shelf dynamics control structure that was not ! previously allocated for registration for restarts. - ! OVS vertically integrated Temperature if (active_shelf_dynamics) then - ! DNG allocate( CS%u_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_bdry_val(:,:) = 0.0 allocate( CS%v_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_bdry_val(:,:) = 0.0 allocate( CS%t_bdry_val(isd:ied,jsd:jed) ) ; CS%t_bdry_val(:,:) = -15.0 @@ -516,46 +526,63 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%calve_mask,G%domain) endif -! call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) - - if (new_sim) then - call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") - call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf, iters, Time) - - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf,CS%diag) - endif + call initialize_ice_shelf_boundary_channel(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + CS%u_flux_bdry_val, CS%v_flux_bdry_val, CS%u_bdry_val, CS%v_bdry_val, CS%u_shelf, CS%v_shelf,& + CS%h_bdry_val, & + CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, & + US, param_file ) + call pass_var(ISS%hmask, G%domain) + call pass_var(CS%h_bdry_val, G%domain) + call pass_var(CS%thickness_bdry_val, G%domain) + call pass_var(CS%u_bdry_val, G%domain) + call pass_var(CS%v_bdry_val, G%domain) + call pass_var(CS%u_face_mask_bdry, G%domain) + call pass_var(CS%v_face_mask_bdry, G%domain) + !call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) ! Register diagnostics. - CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1, Time, & + CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesCu1, Time, & 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) - CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1, Time, & + CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesCv1, Time, & 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) - CS%id_u_mask = register_diag_field('ocean_model','u_mask',CS%diag%axesCu1, Time, & + CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesT1, Time, & + 'x-driving stress of ice', 'kPa', conversion=1.e-9*US%L_T_to_m_s) + CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesT1, Time, & + 'x-driving stress of ice', 'kPa', conversion=1.e-9*US%L_T_to_m_s) + CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesCu1, Time, & 'mask for u-nodes', 'none') - CS%id_v_mask = register_diag_field('ocean_model','v_mask',CS%diag%axesCv1, Time, & + CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesCv1, Time, & 'mask for v-nodes', 'none') -! CS%id_surf_elev = register_diag_field('ocean_model','ice_surf',CS%diag%axesT1, Time, & -! 'ice surf elev', 'm') - CS%id_ground_frac = register_diag_field('ocean_model','ice_ground_frac',CS%diag%axesT1, Time, & + CS%id_ground_frac = register_diag_field('ice_shelf_model','ice_ground_frac',CS%diag%axesT1, Time, & 'fraction of cell that is grounded', 'none') - CS%id_col_thick = register_diag_field('ocean_model','col_thick',CS%diag%axesT1, Time, & + + CS%id_col_thick = register_diag_field('ice_shelf_model','col_thick',CS%diag%axesT1, Time, & 'ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) - CS%id_OD_av = register_diag_field('ocean_model','OD_av',CS%diag%axesT1, Time, & + CS%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',CS%diag%axesT1, Time, & + 'viscosity', 'm', conversion=1e-6*US%Z_to_m) + CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) - !CS%id_h_after_uflux = register_diag_field('ocean_model','h_after_uflux',CS%diag%axesh1, Time, & - ! 'thickness after u flux ', 'none') - !CS%id_h_after_vflux = register_diag_field('ocean_model','h_after_vflux',CS%diag%axesh1, Time, & - ! 'thickness after v flux ', 'none') - !CS%id_h_after_adv = register_diag_field('ocean_model','h_after_adv',CS%diag%axesh1, Time, & - ! 'thickness after front adv ', 'none') - -!!! OVS vertically integrated temperature - CS%id_t_shelf = register_diag_field('ocean_model','t_shelf',CS%diag%axesT1, Time, & - 'T of ice', 'oC') - CS%id_t_mask = register_diag_field('ocean_model','tmask',CS%diag%axesT1, Time, & - 'mask for T-nodes', 'none') + CS%id_h_after_uflux = register_diag_field('ice_shelf_model','h_after_uflux',CS%diag%axesT1, Time, & + 'thickness after u flux ', 'none') + CS%id_h_after_vflux = register_diag_field('ice_shelf_model','h_after_vflux',CS%diag%axesT1, Time, & + 'thickness after v flux ', 'none') + CS%id_h_after_adv = register_diag_field('ice_shelf_model','h_after_adv',CS%diag%axesT1, Time, & + 'thickness after front adv ', 'none') + if (new_sim) then + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf,CS%diag) + if (CS%id_taudx_shelf > 0) call post_data(CS%id_taudx_shelf, CS%taudx_shelf,CS%diag) + if (CS%id_taudy_shelf > 0) call post_data(CS%id_taudy_shelf, CS%taudy_shelf,CS%diag) + if (CS%id_visc_shelf > 0) call post_data(CS%id_visc_shelf, CS%ice_visc,CS%diag) +! CS%id_t_shelf = register_diag_field('ocean_model','t_shelf',CS%diag%axesT1, Time, & +! 'T of ice', 'oC') +! CS%id_t_mask = register_diag_field('ocean_model','tmask',CS%diag%axesT1, Time, & +! 'mask for T-nodes', 'none') + endif endif end subroutine initialize_ice_shelf_dyn @@ -592,8 +619,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) enddo enddo - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf, iters, dummy_time) - + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) end subroutine initialize_diagnostic_fields !> This function returns the global maximum advective timestep that can be taken based on the current @@ -652,7 +678,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled coupled_GL = .false. if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding - +! call ice_shelf_advect(CS, ISS, G, time_step, Time) CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. @@ -663,8 +689,9 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) endif + if (update_ice_vel) then - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf, iters, Time) + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) endif call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) @@ -675,8 +702,11 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) + if (CS%id_taudx_shelf > 0) call post_data(CS%id_taudx_shelf, CS%taudx_shelf, CS%diag) + if (CS%id_taudy_shelf > 0) call post_data(CS%id_taudy_shelf, CS%taudy_shelf, CS%diag) if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac,CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) + if (CS%id_visc_shelf > 0) call post_data(CS%id_visc_shelf, CS%ice_visc,CS%diag) if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) @@ -738,16 +768,16 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_uflux, uh_ice) ! call enable_averages(time_step, Time, CS%diag) -! call pass_var(h_after_uflux, G%domain) -! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) + call pass_var(h_after_uflux, G%domain) + if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) ! call disable_averaging(CS%diag) LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, h_after_uflux, h_after_vflux, vh_ice) ! call enable_averages(time_step, Time, CS%diag) -! call pass_var(h_after_vflux, G%domain) -! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) + call pass_var(h_after_vflux, G%domain) + if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) ! call disable_averaging(CS%diag) do j=jsd,jed @@ -777,7 +807,9 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) end subroutine ice_shelf_advect -subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) +!>This subroutine computes u- and v-velocities of the ice shelf iterating on non-linear ice viscosity +!subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) + subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, iters, Time) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -790,7 +822,10 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time - real, dimension(SZDIB_(G),SZDJB_(G)) :: taudx, taudy ! Driving stresses at q-points [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: taudx !< Driving x-stress at q-points [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] @@ -824,10 +859,20 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) ! need to make these conditional on GL interpolation float_cond(:,:) = 0.0 ; H_node(:,:) = 0.0 + CS%ground_frac(:,:) = 0.0 allocate(Phisub(nsub,nsub,2,2,2,2)) ; Phisub(:,:,:,:,:,:) = 0.0 - call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) + do j=G%jsc,G%jec + do i=G%isc,G%iec + if (rhoi_rhow * ISS%h_shelf(i,j) - G%bathyT(i,j) > 0) then + float_cond(i,j) = 1.0 + CS%ground_frac(i,j) = 1.0 + endif + enddo + enddo + call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) + call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) ! This is to determine which cells contain the grounding line, the criterion being that the cell ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by ! assuming topography is cellwise constant and H is bilinear in a cell; floating where @@ -868,8 +913,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) enddo ; enddo call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain) + call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain) ! This makes sure basal stress is only applied when it is supposed to be @@ -885,7 +930,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - + call pass_vector(Au,Av,G%domain) if (CS%nonlin_solve_err_mode == 1) then err_init = 0 ; err_tempu = 0 ; err_tempv = 0 do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB @@ -921,6 +966,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) + call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain) ! makes sure basal stress is only applied when it is supposed to be @@ -987,8 +1033,11 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call MOM_mesg(mesg, 5) if (err_max <= CS%nonlinear_tolerance * err_init) then + write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init + call MOM_mesg(mesg) write(mesg,*) "ice_shelf_solve_outer: exiting nonlinear solve after ",iter," iterations" - call MOM_mesg(mesg, 5) +! call MOM_mesg(mesg, 5) + call MOM_mesg(mesg) exit endif @@ -1074,7 +1123,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H rhoi_rhow = CS%density_ice / CS%density_ocean_avg Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 - Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 + Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 ; RHSu(:,:) = 0 ; RHSv(:,:) = 0 Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 dot_p1 = 0 @@ -1126,8 +1175,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jsdq,jedq do i=isdq,iedq - if (CS%umask(I,J) == 1) Zu(I,J) = Ru(I,J) / DIAGu(I,J) - if (CS%vmask(I,J) == 1) Zv(I,J) = Rv(I,J) / DIAGv(I,J) + if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) Zu(I,J) = Ru(I,J) / DIAGu(I,J) + if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) Zv(I,J) = Rv(I,J) / DIAGv(I,J) enddo enddo @@ -1162,7 +1211,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! Au, Av valid region moves in by 1 - + call pass_vector(Au,Av,G%domain, TO_ALL, BGRID_NE) sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq @@ -1206,10 +1255,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jsdq,jedq do i=isdq,iedq - if (CS%umask(I,J) == 1) then + if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) then Zu(I,J) = Ru(I,J) / DIAGu(I,J) endif - if (CS%vmask(I,J) == 1) then + if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) then Zv(I,J) = Rv(I,J) / DIAGv(I,J) endif enddo @@ -1264,9 +1313,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H cg_halo = cg_halo - 1 if (cg_halo == 0) then - ! pass vectors + ! pass vectors call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) + call pass_var(u_shlf, G%domain) + call pass_var(v_shlf, G%domain) call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) cg_halo = 3 endif @@ -1733,7 +1784,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) BASE ! basal elevation of shelf/stream [Z ~> m]. - real :: rho, rhow ! Ice and ocean densities [R ~> kg m-3] + real :: rho, rhow, rhoi_rhow ! Ice and ocean densities [R ~> kg m-3] real :: sx, sy ! Ice shelf top slopes [Z L-1 ~> m s-1] real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] real :: dxh, dyh ! Local grid spacing [L ~> m] @@ -1747,21 +1798,35 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB isd = G%isd ; jsd = G%jsd iegq = G%iegB ; jegq = G%jegB - gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 - giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo +! gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + gisc = 1 ; gjsc = 1 +! giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo + giec = G%domain%niglobal ; gjec = G%domain%njglobal is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset rho = CS%density_ice rhow = CS%density_ocean_avg grav = CS%g_Earth - + rhoi_rhow = rho/rhow ! prelim - go through and calculate S ! or is this faster? BASE(:,:) = -G%bathyT(:,:) + OD(:,:) S(:,:) = BASE(:,:) + ISS%h_shelf(:,:) + ! check whether the ice is floating or grounded + do j=jsc-G%domain%njhalo,jec+G%domain%njhalo + do i=isc-G%domain%nihalo,iec+G%domain%nihalo + +! if (ISS%h_shelf(i,j) < rhow/rho * G%bathyT(i,j)) then + if (rhoi_rhow * ISS%h_shelf(i,j) - G%bathyT(i,j) <= 0) then + S(i,j)=(1 - rhoi_rhow)*ISS%h_shelf(i,j) + endif + + + enddo + enddo do j=jsc-1,jec+1 do i=isc-1,iec+1 cnt = 0 @@ -1774,7 +1839,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! calculate sx if ((i+i_off) == gisc) then ! at left computational bdry - if (ISS%hmask(i+1,j) == 1) then + if (ISS%hmask(i+1,j) == 1) then sx = (S(i+1,j)-S(i,j))/dxh else sx = 0 @@ -1841,23 +1906,28 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif ! SW vertex - taudx(I-1,J-1) = taudx(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I-1,J-1) = taudy(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - + if (ISS%hmask(I-1,J-1) == 1) then + taudx(I-1,J-1) = taudx(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I-1,J-1) = taudy(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + endif ! SE vertex - taudx(I,J-1) = taudx(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I,J-1) = taudy(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - + if (ISS%hmask(I,J-1) == 1) then + taudx(I,J-1) = taudx(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I,J-1) = taudy(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + endif ! NW vertex - taudx(I-1,J) = taudx(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I-1,J) = taudy(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - + if (ISS%hmask(I-1,J) == 1) then + taudx(I-1,J) = taudx(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I-1,J) = taudy(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + endif ! NE vertex - taudx(I,J) = taudx(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I,J) = taudy(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - + if (ISS%hmask(I,J) == 1) then + taudx(I,J) = taudx(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I,J) = taudy(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + endif if (CS%ground_frac(i,j) == 1) then - neumann_val = .5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * G%bathyT(i,j)**2) +! neumann_val = .5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * G%bathyT(i,j)**2) + neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2 else neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2 endif @@ -1977,7 +2047,7 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2]. - real, dimension(SZDI_(G),SZDJ_(G),8,4), & + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & @@ -2081,7 +2151,7 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; ;Jtgt = J-2+jphi if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) @@ -2215,7 +2285,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j - do iq=1,2 ; do jq=1,2 ; do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi + do iq=1,2 ; do jq=1,2 ; do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 @@ -2259,7 +2329,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, if (float_cond(i,j) == 1) then Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_diagonal_subgrid_basal(Phisub, Hcell, G%bathyT(i,j), dens_ratio, sub_ground) - do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi if (CS%umask(Itgt,Jtgt) == 1) then u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) @@ -2400,7 +2470,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, CS%v_bdry_val(I-1,J) * Phi(6,2*(jq-1)+iq) + & CS%v_bdry_val(I,J) * Phi(8,2*(jq-1)+iq) - do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 @@ -2447,6 +2517,8 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, endif endif ; enddo ; enddo + call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL, BGRID_NE) + end subroutine apply_boundary_values !> Update depth integrated viscosity, based on horizontal strain rates, and also update the @@ -2468,12 +2540,15 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) ! also this subroutine updates the nonlinear part of the basal traction ! this may be subject to change later... to make it "hybrid" - - integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq - integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js +! real, dimension(SZDIB_(G),SZDJB_(G)) :: eII, ux, uy, vx, vy + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, iq, jq + integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js, i_off, j_off real :: Visc_coef, n_g - real :: ux, uy, vx, vy, eps_min ! Velocity shears [T-1 ~> s-1] - real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] + real :: ux, uy, vx, vy + real :: eps_min, dxh, dyh ! Velocity shears [T-1 ~> s-1] + real, dimension(8,4) :: Phi + real, dimension(2) :: xquad +! real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -2482,22 +2557,65 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc is = iscq - 1; js = jscq - 1 + i_off = G%idg_offset ; j_off = G%jdg_offset n_g = CS%n_glen; eps_min = CS%eps_glen_min - Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(1./CS%n_glen) - - do j=jsd+1,jed-1 - do i=isd+1,ied-1 - - if (ISS%hmask(i,j) == 1) then - ux = ((u_shlf(I,J) + u_shlf(I,J-1)) - (u_shlf(I-1,J) + u_shlf(I-1,J-1))) / (2*G%dxT(i,j)) - vx = ((v_shlf(I,J) + v_shlf(I,J-1)) - (v_shlf(I-1,J) + v_shlf(I-1,J-1))) / (2*G%dxT(i,j)) - uy = ((u_shlf(I,J) + u_shlf(I-1,J)) - (u_shlf(I,J-1) + u_shlf(I-1,J-1))) / (2*G%dyT(i,j)) - vy = ((v_shlf(I,J) + v_shlf(I-1,J)) - (v_shlf(I,J-1) + v_shlf(I-1,J-1))) / (2*G%dyT(i,j)) + Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(-1./CS%n_glen) + do j=jsc,jec + do i=isc,iec + + if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then + ux = ((u_shlf(I,J) + (u_shlf(I,J-1) + u_shlf(I,J+1))) - & + (u_shlf(I-1,J) + (u_shlf(I-1,J-1) + u_shlf(I-1,J+1)))) / (3*G%dxT(i,j)) + vx = ((v_shlf(I,J) + v_shlf(I,J-1) + v_shlf(I,J+1)) - & + (v_shlf(I-1,J) + (v_shlf(I-1,J-1) + v_shlf(I-1,J+1)))) / (3*G%dxT(i,j)) + uy = ((u_shlf(I,J) + (u_shlf(I-1,J) + u_shlf(I+1,J))) - & + (u_shlf(I,J-1) + (u_shlf(I-1,J-1) + u_shlf(I+1,J-1)))) / (3*G%dyT(i,j)) + vy = ((v_shlf(I,J) + (v_shlf(I-1,J)+ v_shlf(I+1,J))) - & + (v_shlf(I,J-1) + (v_shlf(I-1,J-1)+ v_shlf(I+1,J-1)))) / (3*G%dyT(i,j)) CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) + endif + enddo + enddo +end subroutine calc_shelf_visc + +subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + +! also this subroutine updates the nonlinear part of the basal traction + +! this may be subject to change later... to make it "hybrid" + + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq + integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js + real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + iegq = G%iegB ; jegq = G%jegB + gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc + is = iscq - 1; js = jscq - 1 + + eps_min = CS%eps_glen_min + + + do j=jsd+1,jed + do i=isd+1,ied + + if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 unorm = sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) @@ -2506,7 +2624,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) enddo enddo -end subroutine calc_shelf_visc +end subroutine calc_shelf_taub subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure @@ -2674,8 +2792,18 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) do qpoint=1,4 - a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) - d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) + if (J>1) then + a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) + else + a= G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) + endif + if (I>1) then + d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) + else + d = G%dyCu(I,j) !* xquad(qpoint) + endif +! a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) +! d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) do node=1,4 xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) @@ -2799,16 +2927,18 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face if (hmask(i,j) == 1) then - umask(I-1:I,j-1:j) = 1. - vmask(I-1:I,j-1:j) = 1. + umask(I,j) = 1. + vmask(I,j) = 1. do k=0,1 select case (int(CS%u_face_mask_bdry(I-1+k,j))) case (3) - umask(I-1+k,J-1:J)=3. - vmask(I-1+k,J-1:J)=0. + ! vmask(I-1+k,J-1)=0. u_face_mask(I-1+k,j)=3. + umask(I-1+k,J)=3. + !vmask(I-1+k,J)=0. + vmask(I-1+k,J)=3. case (2) u_face_mask(I-1+k,j)=2. case (4) @@ -2829,8 +2959,10 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face select case (int(CS%v_face_mask_bdry(i,J-1+k))) case (3) - vmask(I-1:I,J-1+k)=3. - umask(I-1:I,J-1+k)=0. + vmask(I-1,J-1+k)=3. + umask(I-1,J-1+k)=0. + vmask(I,J-1+k)=3. + umask(I,J-1+k)=0. v_face_mask(i,J-1+k)=3. case (2) v_face_mask(i,J-1+k)=2. @@ -2848,21 +2980,6 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face end select enddo - !if (CS%u_face_mask_bdry(I-1,j) >= 0) then ! Western boundary - ! u_face_mask(I-1,j) = CS%u_face_mask_bdry(I-1,j) - ! umask(I-1,J-1:J) = 3. - ! vmask(I-1,J-1:J) = 0. - !endif - - !if (j_off+j == gjsc+1) then ! SoutherN boundary - ! v_face_mask(i,J-1) = 0. - ! umask(I-1:I,J-1) = 0. - ! vmask(I-1:I,J-1) = 0. - !elseif (j_off+j == gjec) then ! Northern boundary - ! v_face_mask(i,J) = 0. - ! umask(I-1:I,J) = 0. - ! vmask(I-1:I,J) = 0. - !endif if (i < G%ied) then if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then @@ -2984,7 +3101,6 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1] type(time_type), intent(in) :: Time !< The current model time -! 5/23/12 OVS ! This subroutine takes the velocity (on the Bgrid) and timesteps ! (HT)_t = - div (uHT) + (adot Tsurf -bdot Tbot) once and then calculates T=HT/H ! @@ -3020,12 +3136,6 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) TH(i,j) = CS%t_shelf(i,j)*ISS%h_shelf(i,j) enddo ; enddo -! call enable_averages(time_step, Time, CS%diag) -! call pass_var(h_after_uflux, G%domain) -! call pass_var(h_after_vflux, G%domain) -! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) -! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) -! call disable_averaging(CS%diag) call ice_shelf_advect_temp_x(CS, G, time_step, ISS%hmask, TH, th_after_uflux) call ice_shelf_advect_temp_y(CS, G, time_step, ISS%hmask, th_after_uflux, th_after_vflux) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 9fe8028ac6..7a59d1586d 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -16,8 +16,9 @@ module MOM_ice_shelf_initialize #include -!MJHpublic initialize_ice_shelf_boundary, initialize_ice_thickness public initialize_ice_thickness +public initialize_ice_shelf_boundary_channel +public initialize_ice_flow_from_file ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -128,10 +129,6 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U call MOM_read_data(filename, trim(thickness_varname), h_shelf, G%Domain, scale=US%m_to_Z) call MOM_read_data(filename,trim(area_varname), area_shelf_h, G%Domain, scale=US%m_to_L**2) -! call get_param(PF, mdl, "ICE_BOUNDARY_CONFIG", config, & -! "This specifies how the ice domain boundary is specified", & -! fail_if_missing=.true.) - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec do j=jsc,jec @@ -224,7 +221,6 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, if (G%geoLonCu(i-1,j) >= edge_pos) then ! Everything past the edge is open ocean. -! mass_shelf(i,j) = 0.0 area_shelf_h(i,j) = 0.0 hmask (i,j) = 0.0 h_shelf (i,j) = 0.0 @@ -240,11 +236,7 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, if (G%geoLonT(i,j) > slope_pos) then h_shelf(i,j) = min_draft -! mass_shelf(i,j) = Rho_ocean * min_draft else -! mass_shelf(i,j) = Rho_ocean * (min_draft + & -! (CS%max_draft - CS%min_draft) * & -! min(1.0, (c1*(slope_pos - G%geoLonT(i,j)))**2) ) h_shelf(i,j) = (min_draft + & (max_draft - min_draft) * & min(1.0, (c1*(slope_pos - G%geoLonT(i,j)))**2) ) @@ -262,165 +254,198 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, end subroutine initialize_ice_thickness_channel -!BEGIN MJH -! subroutine initialize_ice_shelf_boundary(u_face_mask_bdry, v_face_mask_bdry, & -! u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, h_bdry_val, & -! hmask, G, US, PF ) - -! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure -! real, dimension(SZIB_(G),SZJ_(G)), & -! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces -! real, dimension(SZIB_(G),SZJ_(G)), & -! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through -! !! C-grid u faces [L Z T-1 ~> m2 s-1]. -! real, dimension(SZI_(G),SZJB_(G)), & -! intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces -! real, dimension(SZI_(G),SZJB_(G)), & -! intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through -! !! C-grid v faces [L Z T-1 ~> m2 s-1]. -! real, dimension(SZIB_(G),SZJB_(G)), & -! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open -! !! boundary vertices [L T-1 ~> m s-1]. -! real, dimension(SZIB_(G),SZJB_(G)), & -! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open -! !! boundary vertices [L T-1 ~> m s-1]. -! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] -! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(inout) :: hmask !< A mask indicating which tracer points are -! !! partly or fully covered by an ice-shelf -! type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors -! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters - -! character(len=40) :: mdl = "initialize_ice_shelf_boundary" ! This subroutine's name. -! character(len=200) :: config -! logical flux_bdry - -! call get_param(PF, mdl, "ICE_BOUNDARY_CONFIG", config, & -! "This specifies how the ice domain boundary is specified. "//& -! "valid values include CHANNEL, FILE and USER.", & -! fail_if_missing=.true.) -! call get_param(PF, mdl, "ICE_BOUNDARY_FLUX_CONDITION", flux_bdry, & -! "This specifies whether mass input is a dirichlet or "//& -! "flux condition", default=.true.) - -! select case ( trim(config) ) -! case ("CHANNEL") -! call initialize_ice_shelf_boundary_channel(u_face_mask_bdry, & -! v_face_mask_bdry, u_flux_bdry_val, v_flux_bdry_val, & -! u_bdry_val, v_bdry_val, h_bdry_val, hmask, G, & -! flux_bdry, PF) -! case ("FILE"); call MOM_error(FATAL,"MOM_initialize: "// & -! "Unrecognized topography setup "//trim(config)) -! case ("USER"); call MOM_error(FATAL,"MOM_initialize: "// & -! "Unrecognized topography setup "//trim(config)) -! case default ; call MOM_error(FATAL,"MOM_initialize: "// & -! "Unrecognized topography setup "//trim(config)) -! end select - -! end subroutine initialize_ice_shelf_boundary - -! subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_bdry, & -! u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, h_bdry_val, & -! hmask, G, flux_bdry, US, PF ) - -! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure -! real, dimension(SZIB_(G),SZJ_(G)), & -! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces -! real, dimension(SZIB_(G),SZJ_(G)), & -! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through -! !! C-grid u faces [L Z T-1 ~> m2 s-1]. -! real, dimension(SZI_(G),SZJB_(G)), & -! intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces -! real, dimension(SZI_(G),SZJB_(G)), & -! intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through -! !! C-grid v faces [L Z T-1 ~> m2 s-1]. -! real, dimension(SZIB_(G),SZJB_(G)), & -! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. -! real, dimension(SZIB_(G),SZJB_(G)), & -! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open +!> Initialize ice shelf boundary conditions for a channel configuration +subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_bdry, & + u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, u_shelf, v_shelf, h_bdry_val, & + thickness_bdry_val, hmask, h_shelf, G,& + US, PF ) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJ_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces + real, dimension(SZIB_(G),SZJ_(G)), & + intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through + !! C-grid u faces [L Z T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces + real, dimension(SZI_(G),SZJB_(G)), & + intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through + !! C-grid v faces [L Z T-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open !! boundary vertices [L T-1 ~> m s-1]. -! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] -! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(inout) :: hmask !< A mask indicating which tracer points are -! !! partly or fully covered by an ice-shelf -! logical, intent(in) :: flux_bdry !< If true, use mass fluxes as the boundary value. -! type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors -! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters - -! character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. -! integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc, isc, jsc, iec, jec, ied, jed -! real :: input_thick ! The input ice shelf thickness [Z ~> m] -! real :: input_flux ! The input ice flux per unit length [L Z T-1 ~> m2 s-1] -! real :: lenlat, len_stress - -! call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) - -! call get_param(PF, mdl, "INPUT_FLUX_ICE_SHELF", input_flux, & -! "volume flux at upstream boundary", & -! units="m2 s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) -! call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & -! "flux thickness at upstream boundary", & -! units="m", default=1000., scale=US%m_to_Z) -! call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & -! "maximum position of no-flow condition in along-flow direction", & -! units="km", default=0.) - -! call MOM_mesg(mdl//": setting boundary") - -! isd = G%isd ; ied = G%ied -! jsd = G%jsd ; jed = G%jed -! isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec -! gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo -! giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc - -! do j=jsd,jed -! do i=isd,ied - -! ! upstream boundary - set either dirichlet or flux condition - -! if ((i+G%idg_offset) == G%domain%nihalo+1) then -! if (flux_bdry) then -! u_face_mask_bdry(i-1,j) = 4.0 -! u_flux_bdry_val(i-1,j) = input_flux -! else -! hmask(i-1,j) = 3.0 -! h_bdry_val(i-1,j) = input_thick -! u_face_mask_bdry(i-1,j) = 3.0 -! u_bdry_val(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*lenlat)*2./lenlat)**2) * & -! 1.5 * input_flux / input_thick -! u_bdry_val(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*lenlat)*2./lenlat)**2) * & -! 1.5 * input_flux / input_thick -! endif -! endif - -! ! side boundaries: no flow - -! if (G%jdg_offset+j == gjsc+1) then !bot boundary -! if (len_stress == 0. .OR. G%geoLonCv(i,j-1) <= len_stress) then -! v_face_mask_bdry(i,j-1) = 0. -! else -! v_face_mask_bdry(i,j-1) = 1. -! endif -! elseif (G%jdg_offset+j == gjec) then !top boundary -! if (len_stress == 0. .OR. G%geoLonCv(i,j-1) <= len_stress) then -! v_face_mask_bdry(i,j) = 0. -! else -! v_face_mask_bdry(i,j) = 1. -! endif -! endif - -! ! downstream boundary - CFBC - -! if (i+G%idg_offset == giec) then -! u_face_mask_bdry(i,j) = 2.0 -! endif - -! enddo -! enddo - -!END MJH end subroutine initialize_ice_shelf_boundary_channel + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< Ice-shelf thickness + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. + integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed + real :: input_thick ! The input ice shelf thickness [Z ~> m] + real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1] + real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises + + + call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) + + call get_param(PF, mdl, "LENLON", lenlon, fail_if_missing=.true.) + + call get_param(PF, mdl, "WESTLON", westlon, fail_if_missing=.true.) + + call get_param(PF, mdl, "SOUTHLAT", southlat, fail_if_missing=.true.) + + call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & + "inflow ice velocity at upstream boundary", & + units="m s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) + call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & + "flux thickness at upstream boundary", & + units="m", default=1000., scale=US%m_to_Z) + call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & + "maximum position of no-flow condition in along-flow direction", & + units="km", default=0.) + + call MOM_mesg(mdl//": setting boundary") + + isd = G%isd ; ied = G%ied + jsd = G%jsd ; jed = G%jed + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + gjsd = G%Domain%njglobal ; gisd = G%Domain%niglobal + gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo + giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc + + !---------b.c.s based on geopositions ----------------- + do j=jsc,jec+1 + do i=isc-1,iec+1 + ! upstream boundary - set either dirichlet or flux condition + + if (G%geoLonBu(i,j) == westlon) then + hmask(i+1,j) = 3.0 + h_bdry_val(i+1,j) = h_shelf(i+1,j) + thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) + u_face_mask_bdry(i+1,j) = 3.0 + u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution + endif + + + ! side boundaries: no flow + if (G%geoLatBu(i,j-1) == southlat) then !bot boundary + if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then + v_face_mask_bdry(i,j+1) = 0. + u_face_mask_bdry(i,j) = 3. + u_bdry_val(i,j) = 0. + v_bdry_val(i,j) = 0. + else + v_face_mask_bdry(i,j+1) = 1. + u_face_mask_bdry(i,j) = 3. + u_bdry_val(i,j) = 0. + v_bdry_val(i,j) = 0. + endif + elseif (G%geoLatBu(i,j-1) == southlat+lenlat) then !top boundary + if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then + v_face_mask_bdry(i,j-1) = 0. + u_face_mask_bdry(i,j-1) = 3. + else + v_face_mask_bdry(i,j-1) = 3. + u_face_mask_bdry(i,j-1) = 3. + endif + endif + + ! downstream boundary - CFBC + if (G%geoLonBu(i,j) == westlon+lenlon) then + u_face_mask_bdry(i-1,j) = 2.0 + endif + + enddo + enddo +end subroutine initialize_ice_shelf_boundary_channel + + +!> Initialize ice shelf flow from file +subroutine initialize_ice_flow_from_file(u_shelf, v_shelf,ice_visc,float_cond,& + hmask,h_shelf, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: u_shelf !< The ice shelf u velocity [Z ~> m T ~>s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: v_shelf !< The ice shelf v velocity [Z ~> m T ~> s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: ice_visc !< The ice shelf viscosity [Pa ~> m T ~> s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + ! This subroutine reads ice thickness and area from a file and puts it into + ! h_shelf [Z ~> m] and area_shelf_h [L2 ~> m2] (and dimensionless) and updates hmask + character(len=200) :: filename,vel_file,inputdir ! Strings for file/path + character(len=200) :: ushelf_varname, vshelf_varname, ice_visc_varname, floatfr_varname ! Variable name in file + character(len=40) :: mdl = "initialize_ice_velocity_from_file" ! This subroutine's name. + integer :: i, j, isc, jsc, iec, jec + real :: len_sidestress, mask, udh + + call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_velocity_from_file: reading velocity") + + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(PF, mdl, "ICE_VELOCITY_FILE", vel_file, & + "The file from which the velocity is read.", & + default="ice_shelf_vel.nc") + call get_param(PF, mdl, "LEN_SIDE_STRESS", len_sidestress, & + "position past which shelf sides are stress free.", & + default=0.0, units="axis_units") + + filename = trim(inputdir)//trim(vel_file) + call log_param(PF, mdl, "INPUTDIR/THICKNESS_FILE", filename) + call get_param(PF, mdl, "ICE_U_VEL_VARNAME", ushelf_varname, & + "The name of the thickness variable in ICE_VELOCITY_FILE.", & + default="u_shelf") + call get_param(PF, mdl, "ICE_V_VEL_VARNAME", vshelf_varname, & + "The name of the thickness variable in ICE_VELOCITY_FILE.", & + default="v_shelf") + call get_param(PF, mdl, "ICE_VISC_VARNAME", ice_visc_varname, & + "The name of the thickness variable in ICE_VELOCITY_FILE.", & + default="viscosity") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) + + floatfr_varname = "float_frac" + + call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, scale=1.0) + call MOM_read_data(filename,trim(vshelf_varname), v_shelf, G%Domain, scale=1.0) + call MOM_read_data(filename,trim(ice_visc_varname), ice_visc, G%Domain, scale=1.0) + call MOM_read_data(filename,trim(floatfr_varname), float_cond, G%Domain, scale=1.) + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + do j=jsc,jec + do i=isc,iec + if (hmask(i,j) == 1.) then + ice_visc(i,j) = ice_visc(i,j) * (G%areaT(i,j) * h_shelf(i,j)) + endif + enddo + enddo +end subroutine initialize_ice_flow_from_file end module MOM_ice_shelf_initialize diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 70ef0768d5..f12a388897 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -196,6 +196,7 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) character(len=40) :: mdl = "apply_topography_edits_from_file" ! This subroutine's name. integer :: i, j, n, ncid, n_edits, i_file, j_file, ndims, sizes(8) logical :: found + logical :: topo_edits_change_mask call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") @@ -206,6 +207,9 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) call get_param(param_file, mdl, "TOPO_EDITS_FILE", topo_edits_file, & "The file from which to read a list of i,j,z topography overrides.", & default="") + call get_param(param_file, mdl, "ALLOW_LANDMASK_CHANGES", topo_edits_change_mask, & + "If true, allow topography overrides to change land mask.", & + default=.false.) if (len_trim(topo_edits_file)==0) return @@ -250,8 +254,14 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) 'Ocean topography edit: ', n, ig(n), jg(n), D(i,j)/m_to_Z, '->', abs(new_depth(n)), i, j D(i,j) = abs(m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) else - call MOM_error(FATAL, trim(mdl)//': A zero depth edit would change the land mask and '//& - "is not allowed in"//trim(topo_edits_file)) + if (topo_edits_change_mask) then + write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & + 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)/m_to_Z,'->',abs(new_depth(n)),i,j + D(i,j) = abs(m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) + else + call MOM_error(FATAL, ' apply_topography_edits_from_file: '//& + "A zero depth edit would change the land mask and is not allowed in"//trim(topo_edits_file)) + endif endif endif enddo @@ -1184,17 +1194,18 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables. - character(len=240) :: filepath + character(len=240) :: filepath ! The full path to the file to write character(len=40) :: mdl = "write_ocean_geometry_file" - integer, parameter :: nFlds=23 - type(vardesc) :: vars(nFlds) - type(fieldtype) :: fields(nFlds) + type(vardesc), dimension(:), allocatable :: & + vars ! Types with metadata about the variables and their staggering + type(fieldtype), dimension(:), allocatable :: & + fields ! Opaque types used by MOM_io to store variable metadata information real :: Z_to_m_scale ! A unit conversion factor from Z to m real :: s_to_T_scale ! A unit conversion factor from T-1 to s-1 real :: L_to_m_scale ! A unit conversion factor from L to m type(file_type) :: IO_handle ! The I/O handle of the fileset + integer :: nFlds ! The number of variables in this file integer :: file_threading - integer :: nFlds_used logical :: multiple_files call callTree_enter('write_ocean_geometry_file()') @@ -1203,6 +1214,12 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) s_to_T_scale = 1.0 ; if (present(US)) s_to_T_scale = US%s_to_T L_to_m_scale = 1.0 ; if (present(US)) L_to_m_scale = US%L_to_m + + nFlds = 19 ; if (G%bathymetry_at_vel) nFlds = 23 + + allocate(vars(nFlds)) + allocate(fields(nFlds)) + ! var_desc populates a type defined in MOM_io.F90. The arguments, in order, are: ! (1) the variable name for the NetCDF file ! (2) the units of the variable when output @@ -1234,13 +1251,12 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) vars(18)= var_desc("dyCuo","m","Open meridional grid spacing at u points",'u','1','1') vars(19)= var_desc("wet", "nondim", "land or ocean?", 'h','1','1') - vars(20) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') - vars(21) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') - vars(22) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') - vars(23) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') - - - nFlds_used = 19 ; if (G%bathymetry_at_vel) nFlds_used = 23 + if (G%bathymetry_at_vel) then + vars(20) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') + vars(21) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') + vars(22) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') + vars(23) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') + endif if (present(geom_file)) then filepath = trim(directory) // trim(geom_file) @@ -1255,7 +1271,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) file_threading = SINGLE_FILE if (multiple_files) file_threading = MULTIPLE - call create_file(IO_handle, trim(filepath), vars, nFlds_used, fields, file_threading, dG=G) + call create_file(IO_handle, trim(filepath), vars, nFlds, fields, file_threading, dG=G) call MOM_write_field(IO_handle, fields(1), G%Domain, G%geoLatBu) call MOM_write_field(IO_handle, fields(2), G%Domain, G%geoLonBu) @@ -1290,6 +1306,8 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) call close_file(IO_handle) + deallocate(vars, fields) + call callTree_leave('write_ocean_geometry_file()') end subroutine write_ocean_geometry_file diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 5050b6fce3..b017f9d2df 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -28,7 +28,7 @@ module MOM_state_initialization use MOM_open_boundary, only : update_OBC_segment_data !use MOM_open_boundary, only : set_3D_OBC_data use MOM_grid_initialize, only : initialize_masks, set_grid_metrics -use MOM_restart, only : restore_state, determine_is_new_run, MOM_restart_CS +use MOM_restart, only : restore_state, is_new_run, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density use MOM_sponge, only : initialize_sponge, sponge_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, set_up_ALE_sponge_vel_field @@ -190,7 +190,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call get_param(PF, mdl, "DEBUG", debug, default=.false.) call get_param(PF, mdl, "DEBUG_OBC", debug_obc, default=.false.) - new_sim = determine_is_new_run(dirs%input_filename, dirs%restart_input_dir, G, restart_CS) + new_sim = is_new_run(restart_CS) just_read = .not.new_sim call get_param(PF, mdl, "INPUTDIR", inputdir, & diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index fc6d97040a..661fb715e7 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -188,6 +188,7 @@ module MOM_hor_visc integer :: id_diffu = -1, id_diffv = -1 ! integer :: id_hf_diffu = -1, id_hf_diffv = -1 integer :: id_hf_diffu_2d = -1, id_hf_diffv_2d = -1 + integer :: id_intz_diffu_2d = -1, id_intz_diffv_2d = -1 integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 @@ -276,9 +277,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] - real, allocatable, dimension(:,:) :: hf_diffu_2d ! Depth sum of hf_diffu [L T-2 ~> m s-2] - real, allocatable, dimension(:,:) :: hf_diffv_2d ! Depth sum of hf_diffv [L T-2 ~> m s-2] - real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] @@ -307,7 +305,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, vort_xy_q, & ! vertical vorticity at corner points [T-1 ~> s-1] sh_xy_q, & ! horizontal shearing strain at corner points [T-1 ~> s-1] GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] - max_diss_rate_q, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] ShSt ! A diagnostic array of shear stress [T-1 ~> s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & KH_u_GME !< interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] @@ -316,7 +313,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & Ah_h, & ! biharmonic viscosity at thickness points [L4 T-1 ~> m4 s-1] Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] - max_diss_rate_h, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] div_xx_h, & ! horizontal divergence [T-1 ~> s-1] @@ -387,6 +383,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, hrat_min, & ! h_min divided by the thickness at the stress point (h or q) [nondim] visc_bound_rem ! fraction of overall viscous bounds that remain to be applied [nondim] + real, dimension(SZIB_(G),SZJ_(G)) :: & + hf_diffu_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] + intz_diffu_2d ! Depth-integral of diffu [L2 T-2 ~> m2 s-2] + + real, dimension(SZI_(G),SZJB_(G)) :: & + hf_diffv_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] + intz_diffv_2d ! Depth-integral of diffv [L2 T-2 ~> m2 s-2] + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -503,8 +507,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask_h, boundary_mask_q, & !$OMP backscat_subround, GME_coeff_limiter, & !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & - !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & - !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & + !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt & !$OMP ) & @@ -1643,23 +1646,39 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! enddo ; enddo ; enddo ! call post_data(CS%id_hf_diffv, CS%hf_diffv, CS%diag) !endif - if (present(ADp) .and. (CS%id_hf_diffu_2d > 0)) then - allocate(hf_diffu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) - hf_diffu_2d(:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - hf_diffu_2d(I,j) = hf_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_hf_diffu_2d, hf_diffu_2d, CS%diag) - deallocate(hf_diffu_2d) - endif - if (present(ADp) .and. (CS%id_hf_diffv_2d > 0)) then - allocate(hf_diffv_2d(G%isd:G%ied,G%JsdB:G%JedB)) - hf_diffv_2d(:,:) = 0.0 - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - hf_diffv_2d(i,J) = hf_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_hf_diffv_2d, hf_diffv_2d, CS%diag) - deallocate(hf_diffv_2d) + + if (present(ADp)) then + if (CS%id_hf_diffu_2d > 0) then + hf_diffu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_diffu_2d(I,j) = hf_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffu_2d, hf_diffu_2d, CS%diag) + endif + + if (CS%id_hf_diffv_2d > 0) then + hf_diffv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_diffv_2d(i,J) = hf_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffv_2d, hf_diffv_2d, CS%diag) + endif + + if (CS%id_intz_diffu_2d > 0) then + intz_diffu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + intz_diffu_2d(I,j) = intz_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_diffu_2d, intz_diffu_2d, CS%diag) + endif + + if (CS%id_intz_diffv_2d > 0) then + intz_diffv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + intz_diffv_2d(i,J) = intz_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_diffv_2d, intz_diffv_2d, CS%diag) + endif endif end subroutine horizontal_viscosity @@ -2378,6 +2397,20 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, MEKE, ADp) call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) endif + CS%id_intz_diffu_2d = register_diag_field('ocean_model', 'intz_diffu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Acceleration from Horizontal Viscosity', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if ((CS%id_intz_diffu_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) + endif + + CS%id_intz_diffv_2d = register_diag_field('ocean_model', 'intz_diffv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Acceleration from Horizontal Viscosity', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if ((CS%id_intz_diffv_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) + endif + if (CS%biharmonic) then CS%id_Ah_h = register_diag_field('ocean_model', 'Ahh', diag%axesTL, Time, & 'Biharmonic Horizontal Viscosity at h Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T, & diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 80543d5968..a862dd373d 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -2317,7 +2317,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', h2, G%domain, timelevel=1, scale=US%m_to_Z) + call MOM_read_data(filename, 'h2', h2, G%domain, scale=US%m_to_Z) do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Restrict rms topo to 10 percent of column depth. h2(i,j) = min(0.01*(G%bathyT(i,j))**2, h2(i,j)) @@ -2337,8 +2337,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%refl_angle(isd:ied,jsd:jed)) ; CS%refl_angle(:,:) = CS%nullangle if (file_exists(filename, G%domain)) then call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) - call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & - G%domain, timelevel=1) + call MOM_read_data(filename, 'refl_angle', CS%refl_angle, G%domain) else if (trim(refl_angle_file) /= '' ) call MOM_error(FATAL, & "REFL_ANGLE_FILE: "//trim(filename)//" not found") @@ -2357,7 +2356,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%refl_pref(isd:ied,jsd:jed)) ; CS%refl_pref(:,:) = 1.0 if (file_exists(filename, G%domain)) then call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) - call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain) else if (trim(refl_pref_file) /= '' ) call MOM_error(FATAL, & "REFL_PREF_FILE: "//trim(filename)//" not found") @@ -2385,7 +2384,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(ridge_temp(isd:ied,jsd:jed)) ; ridge_temp(:,:) = 0.0 if (file_exists(filename, G%domain)) then call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) - call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain) else if (trim(refl_dbl_file) /= '' ) call MOM_error(FATAL, & "REFL_DBL_FILE: "//trim(filename)//" not found") @@ -2406,9 +2405,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !filename = trim(CS%inputdir) // trim(land_mask_file) !call log_param(param_file, mdl, "INPUTDIR/LAND_MASK_FILE", filename) !G%mask2dCu(:,:) = 1 ; G%mask2dCv(:,:) = 1 ; G%mask2dT(:,:) = 1 - !call MOM_read_data(filename, 'land_mask', G%mask2dCu, G%domain, timelevel=1) - !call MOM_read_data(filename, 'land_mask', G%mask2dCv, G%domain, timelevel=1) - !call MOM_read_data(filename, 'land_mask', G%mask2dT, G%domain, timelevel=1) + !call MOM_read_data(filename, 'land_mask', G%mask2dCu, G%domain) + !call MOM_read_data(filename, 'land_mask', G%mask2dCv, G%domain) + !call MOM_read_data(filename, 'land_mask', G%mask2dT, G%domain) !call pass_vector(G%mask2dCu, G%mask2dCv, G%domain, To_All+Scalar_Pair, CGRID_NE) !call pass_var(G%mask2dT,G%domain) @@ -2419,7 +2418,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !filename = trim(CS%inputdir) // trim(dy_Cu_file) !call log_param(param_file, mdl, "INPUTDIR/dy_Cu_FILE", filename) !G%dy_Cu(:,:) = 0.0 - !call MOM_read_data(filename, 'dy_Cu', G%dy_Cu, G%domain, timelevel=1, scale=US%m_to_L) + !call MOM_read_data(filename, 'dy_Cu', G%dy_Cu, G%domain, scale=US%m_to_L) ! Read in prescribed partial north face blockages from file (if overwriting -BDM) !call get_param(param_file, mdl, "dx_Cv_FILE", dx_Cv_file, & @@ -2428,7 +2427,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !filename = trim(CS%inputdir) // trim(dx_Cv_file) !call log_param(param_file, mdl, "INPUTDIR/dx_Cv_FILE", filename) !G%dx_Cv(:,:) = 0.0 - !call MOM_read_data(filename, 'dx_Cv', G%dx_Cv, G%domain, timelevel=1, scale=US%m_to_L) + !call MOM_read_data(filename, 'dx_Cv', G%dx_Cv, G%domain, scale=US%m_to_L) !call pass_vector(G%dy_Cu, G%dx_Cv, G%domain, To_All+Scalar_Pair, CGRID_NE) ! Register maps of reflection parameters diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index e3a6f1599e..7d95c43b98 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1125,16 +1125,18 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then CS%id_N2_u = register_diag_field('ocean_model', 'N2_u', diag%axesCui, Time, & 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', & - 's-2', conversion=US%s_to_T**2) + 's-2', conversion=(US%L_to_Z*US%s_to_T)**2) CS%id_N2_v = register_diag_field('ocean_model', 'N2_v', diag%axesCvi, Time, & 'Square of Brunt-Vaisala frequency, N^2, at v-points, as used in Visbeck et al.', & - 's-2', conversion=US%s_to_T**2) + 's-2', conversion=(US%L_to_Z*US%s_to_T)**2) endif if (CS%use_stored_slopes) then CS%id_S2_u = register_diag_field('ocean_model', 'S2_u', diag%axesCu1, Time, & - 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', 'nondim') + 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', & + 'nondim', conversion=US%Z_to_L**2) CS%id_S2_v = register_diag_field('ocean_model', 'S2_v', diag%axesCv1, Time, & - 'Depth average square of slope magnitude, S^2, at v-points, as used in Visbeck et al.', 'nondim') + 'Depth average square of slope magnitude, S^2, at v-points, as used in Visbeck et al.', & + 'nondim', conversion=US%Z_to_L**2) endif oneOrTwo = 1.0 diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 8c6a90ba9c..02a49a2a1a 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -40,7 +40,7 @@ module MOM_thickness_diffuse real :: max_Khth_CFL !< Maximum value of the diffusive CFL for thickness diffusion real :: Khth_Min !< Minimum value of Khth [L2 T-1 ~> m2 s-1] real :: Khth_Max !< Maximum value of Khth [L2 T-1 ~> m2 s-1], or 0 for no max - real :: slope_max !< Slopes steeper than slope_max are limited in some way [nondim]. + real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim]. real :: kappa_smooth !< Vertical diffusivity used to interpolate more !! sensible values of T & S into thin layers [Z2 T-1 ~> m2 s-1]. logical :: thickness_diffuse !< If true, interfaces heights are diffused. @@ -83,8 +83,8 @@ module MOM_thickness_diffuse type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics real, pointer :: GMwork(:,:) => NULL() !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] - real, pointer :: diagSlopeX(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [nondim] - real, pointer :: diagSlopeY(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [nondim] + real, pointer :: diagSlopeX(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] + real, pointer :: diagSlopeY(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] real, dimension(:,:,:), pointer :: & KH_u_GME => NULL(), & !< interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] @@ -578,8 +578,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !! the isopycnal slopes are taken directly from !! the interface slopes without consideration of !! density gradients [nondim]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: slope_x !< Isopycnal slope at u-points - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: slope_y !< Isopycnal slope at v-points + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: slope_x !< Isopyc. slope at u [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: slope_y !< Isopyc. slope at v [Z L-1 ~> nondim] ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & T, & ! The temperature (or density) [degC], with the values in @@ -660,7 +660,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: Slope ! The slope of density surfaces, calculated in a way ! that is always between -1 and 1, nondimensional. real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 L-2 ~> kg2 m-8]. - real :: I_slope_max2 ! The inverse of slope_max squared, nondimensional. + real :: I_slope_max2 ! The inverse of slope_max squared [L2 Z-2 ~> nondim]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. @@ -919,7 +919,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = drdx**2 + (US%L_to_Z*drdz)**2 + mag_grad2 = (US%Z_to_L*drdx)**2 + drdz**2 if (mag_grad2 > 0.0) then Slope = drdx / sqrt(mag_grad2) slope2_Ratio_u(I,K) = Slope**2 * I_slope_max2 @@ -933,7 +933,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! that ignore density gradients along layers. if (present_int_slope_u) then Slope = (1.0 - int_slope_u(I,j,K)) * Slope + & - int_slope_u(I,j,K) * US%Z_to_L*((e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j)) + int_slope_u(I,j,K) * ((e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j)) slope2_Ratio_u(I,K) = (1.0 - int_slope_u(I,j,K)) * slope2_Ratio_u(I,K) endif @@ -942,7 +942,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. - Sfn_unlim_u(I,K) = -((KH_u(I,j,K)*G%dy_Cu(I,j))*US%L_to_Z*Slope) + Sfn_unlim_u(I,K) = -((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) ! Avoid moving dense water upslope from below the level of ! the bottom on the receiving side. @@ -968,10 +968,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (present_slope_x) then Slope = slope_x(I,j,k) else - Slope = US%Z_to_L*((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%mask2dCu(I,j) + Slope = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%mask2dCu(I,j) endif if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - Sfn_unlim_u(I,K) = ((KH_u(I,j,K)*G%dy_Cu(I,j))*US%L_to_Z*Slope) + Sfn_unlim_u(I,K) = ((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) hN2_u(I,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) @@ -993,10 +993,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. do I=is-1,ie if (G%mask2dCu(I,j)>0.) then - Sfn_unlim_u(I,:) = ( 1. + CS%FGNV_scale ) * Sfn_unlim_u(I,:) + do K=2,nz + Sfn_unlim_u(I,K) = (1. + CS%FGNV_scale) * Sfn_unlim_u(I,K) + enddo call streamfn_solver(nz, c2_h_u(I,:), hN2_u(I,:), Sfn_unlim_u(I,:)) else - Sfn_unlim_u(I,:) = 0. + do K=2,nz + Sfn_unlim_u(I,K) = 0. + enddo endif enddo endif @@ -1185,7 +1189,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = drdy**2 + (US%L_to_Z*drdz)**2 + mag_grad2 = (US%Z_to_L*drdy)**2 + drdz**2 if (mag_grad2 > 0.0) then Slope = drdy / sqrt(mag_grad2) slope2_Ratio_v(i,K) = Slope**2 * I_slope_max2 @@ -1199,7 +1203,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! that ignore density gradients along layers. if (present_int_slope_v) then Slope = (1.0 - int_slope_v(i,J,K)) * Slope + & - int_slope_v(i,J,K) * US%Z_to_L*((e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J)) + int_slope_v(i,J,K) * ((e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J)) slope2_Ratio_v(i,K) = (1.0 - int_slope_v(i,J,K)) * slope2_Ratio_v(i,K) endif @@ -1208,7 +1212,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. - Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*US%L_to_Z*Slope) + Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) ! Avoid moving dense water upslope from below the level of ! the bottom on the receiving side. @@ -1234,10 +1238,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (present_slope_y) then Slope = slope_y(i,J,k) else - Slope = US%Z_to_L*((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%mask2dCv(i,J) + Slope = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%mask2dCv(i,J) endif if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - Sfn_unlim_v(i,K) = ((KH_v(i,J,K)*G%dx_Cv(i,J))*US%L_to_Z*Slope) + Sfn_unlim_v(i,K) = ((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) hN2_v(i,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) @@ -1259,10 +1263,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. do i=is,ie if (G%mask2dCv(i,J)>0.) then - Sfn_unlim_v(i,:) = ( 1. + CS%FGNV_scale ) * Sfn_unlim_v(i,:) + do K=2,nz + Sfn_unlim_v(i,K) = (1. + CS%FGNV_scale) * Sfn_unlim_v(i,K) + enddo call streamfn_solver(nz, c2_h_v(i,:), hN2_v(i,:), Sfn_unlim_v(i,:)) else - Sfn_unlim_v(i,:) = 0. + do K=2,nz + Sfn_unlim_v(i,K) = 0. + enddo endif enddo endif @@ -1947,7 +1955,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "longer than DT, or 0 to use DT.", units="s", default=0.0, scale=US%s_to_T) call get_param(param_file, mdl, "KHTH_SLOPE_MAX", CS%slope_max, & "A slope beyond which the calculated isopycnal slope is "//& - "not reliable and is scaled away.", units="nondim", default=0.01) + "not reliable and is scaled away.", units="nondim", default=0.01, scale=US%L_to_Z) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & @@ -2065,10 +2073,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) CS%id_slope_x = register_diag_field('ocean_model', 'neutral_slope_x', diag%axesCui, Time, & - 'Zonal slope of neutral surface', 'nondim') + 'Zonal slope of neutral surface', 'nondim', conversion=US%Z_to_L) if (CS%id_slope_x > 0) call safe_alloc_ptr(CS%diagSlopeX,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke+1) CS%id_slope_y = register_diag_field('ocean_model', 'neutral_slope_y', diag%axesCvi, Time, & - 'Meridional slope of neutral surface', 'nondim') + 'Meridional slope of neutral surface', 'nondim', conversion=US%Z_to_L) if (CS%id_slope_y > 0) call safe_alloc_ptr(CS%diagSlopeY,G%isd,G%ied,G%JsdB,G%JedB,GV%ke+1) CS%id_sfn_x = register_diag_field('ocean_model', 'GM_sfn_x', diag%axesCui, Time, & 'Parameterized Zonal Overturning Streamfunction', & diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 649fc725de..c96edb785c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2982,7 +2982,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_hf_dvdt_dia_2d = register_diag_field('ocean_model', 'hf_dvdt_dia_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Diapycnal Mixing', & 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%id_hf_dvdt_dia_2d > 0) call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + if (CS%id_hf_dvdt_dia_2d > 0) call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) if ((CS%id_dudt_dia > 0) .or. (CS%id_hf_dudt_dia_2d > 0)) & call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 7aca829db6..0ede511eb7 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -368,7 +368,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', itide%tideamp, G%domain, timelevel=1, scale=US%m_s_to_L_T) + call MOM_read_data(filename, 'tideamp', itide%tideamp, G%domain, scale=US%m_s_to_L_T) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -377,7 +377,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', itide%h2, G%domain, timelevel=1, scale=US%m_to_Z**2) + call MOM_read_data(filename, 'h2', itide%h2, G%domain, scale=US%m_to_Z**2) call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 6ff8faf2f0..99bd91d8f8 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2246,7 +2246,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS allocate(CS%tideamp(isd:ied,jsd:jed)) ; CS%tideamp(:,:) = 0.0 filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1, scale=US%m_to_Z*US%T_to_s) + call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) call pass_var(CS%tideamp,G%domain) endif endif diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index b870dff1af..21eb52ebe9 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -460,7 +460,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1, scale=US%m_to_Z*US%T_to_s) + call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -469,7 +469,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) fail_if_missing=(.not.CS%use_CVMix_tidal)) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', CS%h2, G%domain, timelevel=1, scale=US%m_to_Z**2) + call MOM_read_data(filename, 'h2', CS%h2, G%domain, scale=US%m_to_Z**2) call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& @@ -882,7 +882,6 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv ! summing q_i*TidalConstituent_i over the number of constituents. call CVMix_compute_SchmittnerCoeff( nlev = GV%ke, & energy_flux = tidal_qe_md(:), & - rho = rho_fw, & SchmittnerCoeff = Schmittner_coeff, & exp_hab_zetar = exp_hab_zetar, & CVmix_tidal_params_user = CS%CVMix_tidal_params) @@ -896,7 +895,6 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv Tdiff_out = Kd_tidal, & Nsqr = N2_int_i, & OceanDepth = -iFaceHeight(GV%ke+1), & - vert_dep = vert_dep, & nlev = GV%ke, & max_nlev = GV%ke, & SchmittnerCoeff = Schmittner_coeff, & diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 7e2c2c6926..c7c9355f97 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1817,7 +1817,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & !if (CS%id_hf_dv_dt_visc > 0) then ! call safe_alloc_ptr(CS%hf_dv_dt_visc,isd,ied,JsdB,JedB,nz) ! call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) - ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) !endif CS%id_hf_du_dt_visc_2d = register_diag_field('ocean_model', 'hf_du_dt_visc_2d', diag%axesCu1, Time, & @@ -1833,7 +1833,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & conversion=US%L_T2_to_m_s2) if (CS%id_hf_dv_dt_visc_2d > 0) then call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) - call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) endif if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) &