diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index befac14642..5e1da1c1f9 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,109 +1,78 @@ stages: - - merge+setup - builds - run - tests - cleanup +variables: + CACHE_DIR: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/cache/" + + # Merges MOM6 with dev/gfdl. Changes directory to test directory, if it exists. +# - set cache location +# - get MOM6-examples/tools/MRS scripts by cloning Gaea-stats and then MOM6-examples +# - set working directory to MOM6-examples +# - pull down latest of dev/gfdl (MOM6-examples might be ahead of Gaea-stats) before_script: - - MOM6_SRC=$CI_PROJECT_DIR - - echo Cache directory set to ${CACHE_DIR:=/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/cache/} - - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl && git submodule init && git submodule update - - pwd ; ls + - echo Cache directory set to $CACHE_DIR + - echo -e "\e[0Ksection_start:`date +%s`:before[collapsed=true]\r\e[0KPre-script" + - git clone https://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git tests + - cd tests && git submodule init && git submodule update + - cd MOM6-examples && git checkout dev/gfdl && git pull + - echo -e "\e[0Ksection_end:`date +%s`:before\r\e[0K" # Tests that merge with dev/gfdl works. merge: - stage: merge+setup + stage: builds tags: - ncrc4 script: - - pwd ; ls + - cd $CI_PROJECT_DIR - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl -# Clones regression repo, if necessary, pulls latest of everything, and sets up working space -setup: - stage: merge+setup - tags: - - ncrc4 - script: - - pwd ; ls - # 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 -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) - - test -d MOM6-examples/src/LM3 || make -f MRS/Makefile.clone clone_gfdl -s - - make -f MRS/Makefile.clone MOM6-examples/.datasets -s - - env > gitlab_session.log - # Cache everything under tests to unpack for each subsequent stage - - cd ../ ; time tar zcf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz tests - # Compiles gnu:repro: stage: builds tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time make -f MRS/Makefile.build MOM6_SRC=../ build_gnu -s -j - - time make -f MRS/Makefile.build MOM6_SRC=../ static_gnu -s -j - - time tar zvcf $CACHE_DIR/build-gnu-repro-$CI_PIPELINE_ID.tgz `find build/gnu -name MOM6` + - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-repro-gnu -s -j + - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-static-gnu -s -j gnu:ocean-only-nolibs: stage: builds tags: - ncrc4 script: - - 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/{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) + - make -f tools/MRS/Makefile pipeline-build-gnu-oceanonly-nolibs gnu:ice-ocean-nolibs: stage: builds tags: - ncrc4 script: - - 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/{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) + - make -f tools/MRS/Makefile pipeline-build-gnu-iceocean-nolibs intel:repro: stage: builds tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build MOM6_SRC=../ build_intel -s -j - - time tar zvcf $CACHE_DIR/build-intel-repro-$CI_PIPELINE_ID.tgz `find build/intel -name MOM6` + - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-repro-intel -s -j pgi:repro: stage: builds tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build MOM6_SRC=../ build_pgi -s -j - - time tar zvcf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz `find build/pgi -name MOM6` + - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-repro-pgi -s -j gnu:debug: stage: builds tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build MOM6_SRC=../ debug_gnu -s -j - - time tar zvcf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz `find build/gnu -name MOM6` + - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-debug-gnu -s -j # Runs run: @@ -111,41 +80,43 @@ run: tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/build-gnu-repro-$CI_PIPELINE_ID.tgz - - time tar zxf $CACHE_DIR/build-intel-repro-$CI_PIPELINE_ID.tgz - - time tar zxf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz - # time tar zxf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz - - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all') > job.sh - - sbatch --clusters=c3,c4 --nodes=29 --time=0:34:00 --account=gfdl_o --qos=debug --job-name=mom6_regressions --output=log.$CI_PIPELINE_ID --wait job.sh || MJOB_RETURN_STATE=Fail - - cat log.$CI_PIPELINE_ID - - test -z "$MJOB_RETURN_STATE" - - test -f restart_results_gnu.tar.gz - - time tar zvcf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz *.tar.gz + - make -f tools/MRS/Makefile mom6-pipeline-run gnu.testing: stage: run tags: - ncrc4 + before_script: + - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" + - git submodule init ; git submodule update + - echo -e "\e[0Ksection_end:`date +%s`:submodules\r\e[0K" script: + - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu darshan ; module load PrgEnv-gnu ; module unload netcdf gcc ; module load gcc/7.3.0 cray-hdf5 cray-netcdf - make work/local-env - make -s -j + - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo '. ./work/local-env/bin/activate';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh - - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_PIPELINE_ID --wait job.sh || cat log.$CI_PIPELINE_ID && make test + - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_PIPELINE_ID --wait job.sh && make test || cat log.$CI_PIPELINE_ID intel.testing: stage: run tags: - ncrc4 + before_script: + - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" + - git submodule init ; git submodule update + - echo -e "\e[0Ksection_end:`date +%s`:submodules\r\e[0K" script: + - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu darshan; module load PrgEnv-intel; module unload netcdf intel; module load intel/18.0.6.288 cray-hdf5 cray-netcdf - make work/local-env - make -s -j + - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo '. ./work/local-env/bin/activate';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh - - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_PIPELINE_ID --wait job.sh || cat log.$CI_PIPELINE_ID && make test + - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_PIPELINE_ID --wait job.sh && make test || cat log.$CI_PIPELINE_ID # Tests gnu:non-symmetric: @@ -153,113 +124,91 @@ gnu:non-symmetric: tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_non_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_non_symmetric -intel:non-symmetric: +gnu:symmetric: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests intel_non_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_symmetric -pgi:non-symmetric: +gnu:memory: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests pgi_non_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_memory -gnu:symmetric: +gnu:static: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_static -intel:symmetric: +gnu:restart: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests intel_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_restarts -pgi:symmetric: +gnu:params: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests pgi_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-params_gnu_symmetric + allow_failure: true -gnu:layout: +intel:symmetric: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_layout + - make -f tools/MRS/Makefile mom6-pipeline-test-intel_symmetric -intel:layout: +intel:non-symmetric: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests intel_layout + - make -f tools/MRS/Makefile mom6-pipeline-test-intel_non_symmetric -pgi:layout: +intel:memory: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests pgi_layout + - make -f tools/MRS/Makefile mom6-pipeline-test-intel_memory -gnu:static: +pgi:symmetric: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_static + - make -f tools/MRS/Makefile mom6-pipeline-test-pgi_symmetric -gnu:restart: +pgi:non-symmetric: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_check_restarts + - make -f tools/MRS/Makefile mom6-pipeline-test-pgi_non_symmetric -gnu:params: +pgi:memory: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests params_gnu_symmetric - allow_failure: true + - make -f tools/MRS/Makefile mom6-pipeline-test-pgi_memory cleanup: stage: cleanup tags: - ncrc4 + before_script: + - echo Skipping submodule update script: - rm $CACHE_DIR/*$CI_PIPELINE_ID.tgz diff --git a/.testing/Makefile b/.testing/Makefile index 02f6557c09..45d05cd23f 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -193,7 +193,7 @@ endif # Rules .PHONY: all build.regressions -all: $(foreach b,$(BUILDS),build/$(b)/MOM6) +all: $(foreach b,$(BUILDS),build/$(b)/MOM6) $(VENV_PATH) build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) # Executable @@ -361,6 +361,7 @@ check_mom6_api_mct: build/mct/mom_ocean_model_mct.o work/local-env: python3 -m venv $@ . $@/bin/activate \ + && python3 -m pip install --upgrade pip \ && pip3 install wheel \ && pip3 install cython \ && pip3 install numpy \ diff --git a/ac/configure.ac b/ac/configure.ac index 6ff4ae5e8b..9cb7147846 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -59,6 +59,18 @@ AS_IF([test "x$with_driver" != "x"], # used to configure a header based on a template. #AC_CONFIG_HEADERS(["$MEM_LAYOUT/MOM_memory.h"]) +# Select the model framework (default: FMS1) +# NOTE: We can phase this out after the FMS1 I/O has been removed from FMS and +# replace with a detection test. For now, it is a user-defined switch. +MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1 +AC_ARG_WITH([framework], + AS_HELP_STRING([--with-framework=fms1|fms2], [Select the model framework])) +AS_CASE([with_framework], + [fms1], [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1], + [fms2], [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2], + [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1] +) + # Explicitly assume free-form Fortran AC_LANG(Fortran) @@ -192,6 +204,22 @@ AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], ) +# Verify that FMS is at least 2019.01.02 +# NOTE: 2019.01.02 introduced two changes: +# - diag_axis_init supports an optional domain_position argument +# - position values NORTH, EAST, CENTER were added to diag_axis_mod +# For our versioning test, we check the second feature. +AC_MSG_CHECKING([if diag_axis_mod supports domain positions]) +AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [use diag_axis_mod, only: NORTH, EAST, CENTER])], + [AC_MSG_RESULT([yes])], + [ + AC_MSG_RESULT([no]) + AC_MSG_ERROR([diag_axis_mod in MOM6 requires FMS 2019.01.02 or newer.]) + ] +) + + # Search for mkmf build tools AC_PATH_PROG([LIST_PATHS], [list_paths]) AS_IF([test -z "$LIST_PATHS"], [ @@ -216,11 +244,14 @@ AS_IF([test -z "$MKMF"], [ AC_CONFIG_COMMANDS([path_names], [list_paths -l \ ${srcdir}/src \ - ${srcdir}/config_src/infra/FMS1 \ + ${MODEL_FRAMEWORK} \ ${srcdir}/config_src/ext* \ ${DRIVER_DIR} \ - ${MEM_LAYOUT} -], [MEM_LAYOUT=$MEM_LAYOUT DRIVER_DIR=$DRIVER_DIR]) + ${MEM_LAYOUT}], + [MODEL_FRAMEWORK=$MODEL_FRAMEWORK + MEM_LAYOUT=$MEM_LAYOUT + DRIVER_DIR=$DRIVER_DIR] +) AC_CONFIG_COMMANDS([Makefile.mkmf], diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index bb89c4e85e..6479549eb7 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -27,7 +27,8 @@ module MOM_surface_forcing_gfdl use MOM_grid, only : ocean_grid_type use MOM_interpolate, only : init_external_field, time_interp_external use MOM_interpolate, only : time_interp_external_init -use MOM_io, only : slasher, write_version_number, MOM_read_data, stdout +use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_io, only : stdout_if_root 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 @@ -36,6 +37,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 @@ -109,6 +111,8 @@ module MOM_surface_forcing_gfdl logical :: restore_temp !< If true, the coupled MOM driver adds a term to restore sea !! surface temperature to a specified value. real :: Flux_const !< Piston velocity for surface restoring [Z T-1 ~> m s-1] + real :: Flux_const_salt !< Piston velocity for surface salt restoring [Z T-1 ~> m s-1] + real :: Flux_const_temp !< Piston velocity for surface temp restoring [Z T-1 ~> m s-1] logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux logical :: adjust_net_srestore_to_zero !< Adjust srestore to zero (for both salt_flux or vprec) logical :: adjust_net_srestore_by_scaling !< Adjust srestore w/o moving zero contour @@ -289,22 +293,18 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) - if (CS%allow_flux_adjustments) then - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - endif + call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo ; enddo - if (CS%restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) endif ! endif for allocation and initialization @@ -334,10 +334,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%fluxes_used = .false. fluxes%dt_buoy_accum = US%s_to_T*valid_time - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:) = 0.0 - fluxes%salt_flux_added(:,:) = 0.0 - endif + fluxes%heat_added(:,:) = 0.0 + fluxes%salt_flux_added(:,:) = 0.0 do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 @@ -358,7 +356,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const_salt)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then @@ -368,9 +366,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%saltFluxGlobalAdj = 0. else work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & - G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) + G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) * G%mask2dT(is:ie,js:je) fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - & + kg_m2_s_conversion * fluxes%saltFluxGlobalAdj * G%mask2dT(is:ie,js:je) endif endif fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic @@ -380,7 +379,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (CS%Rho0*CS%Flux_const) * & + (CS%Rho0*CS%Flux_const_salt) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo @@ -408,7 +407,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sst = data_restore(i,j)- sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & - rhoXcp * delta_sst * CS%Flux_const ! W m-2 + rhoXcp * delta_sst * CS%Flux_const_temp ! W m-2 enddo ; enddo endif @@ -1110,7 +1109,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) type(forcing), intent(inout) :: fluxes !< Surface fluxes structure ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Various fluxes at h points [W m-2] or [kg m-2 s-1] + real, dimension(G%isc:G%iec,G%jsc:G%jec) :: temp_at_h ! Various fluxes at h points [W m-2] or [kg m-2 s-1] integer :: isc, iec, jsc, jec, i, j logical :: overrode_h @@ -1250,6 +1249,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) character(len=48) :: flnam character(len=240) :: basin_file integer :: i, j, isd, ied, jsd, jed + real :: unscaled_fluxconst isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1373,9 +1373,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s,unscaled=unscaled_fluxconst) + call get_param(param_file, mdl, "FLUXCONST_SALT", CS%Flux_const_salt, & + "The constant that relates the restoring surface salt fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + fail_if_missing=.false.,default=unscaled_fluxconst, units="m day-1", scale=US%m_to_Z*US%T_to_s) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 + CS%Flux_const_salt = CS%Flux_const_salt / 86400.0 call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1420,9 +1425,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s,unscaled=unscaled_fluxconst) + call get_param(param_file, mdl, "FLUXCONST_TEMP", CS%Flux_const_temp, & + "The constant that relates the restoring surface temperature fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + fail_if_missing=.false.,default=unscaled_fluxconst, units="m day-1", scale=US%m_to_Z*US%T_to_s) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 + CS%Flux_const_temp = CS%Flux_const_temp / 86400.0 call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") @@ -1622,32 +1632,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 - - 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 ) + ! 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 + + root = is_root_pe() + outunit = stdout_if_root() + + 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/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index f635e886a5..c3e13329f2 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -35,7 +35,7 @@ module ocean_model_mod use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : write_version_number, stdout +use MOM_io, only : write_version_number, stdout_if_root use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase @@ -55,7 +55,8 @@ module ocean_model_mod use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS 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 MOM_wave_interface, only: Update_Surface_Waves +use iso_fortran_env, only : int64 #include @@ -204,7 +205,7 @@ module ocean_model_mod marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. type(wave_parameters_cs), pointer :: & - Waves !< A structure containing pointers to the surface wave fields + Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure type(MOM_restart_CS), pointer :: & @@ -381,11 +382,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) - if (OS%use_waves) then - call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) - else - call MOM_wave_interface_init_lite(param_file) - endif + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initializes statistical waves. + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) call initialize_ocean_public_type(OS%grid%Domain, Ocean_sfc, OS%diag, & gas_fields_ocn=gas_fields_ocn) @@ -1094,25 +1093,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 - - 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) + ! 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 + + root = is_root_pe() + outunit = stdout_if_root() + + 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 +1165,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/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 5a04739971..9b40a9e7b4 100644 --- a/config_src/drivers/mct_cap/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 @@ -60,11 +61,12 @@ module MOM_ocean_model_mct use mpp_mod, only : mpp_chksum use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct 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 MOM_wave_interface, only : Update_Surface_Waves use time_interp_external_mod, only : time_interp_external_init ! MCT specfic routines use MOM_domains, only : MOM_infra_end +use iso_fortran_env, only : int64 #include @@ -203,7 +205,7 @@ module MOM_ocean_model_mct marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. type(wave_parameters_cs), pointer :: & - Waves !< A structure containing pointers to the surface wave fields + Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure type(MOM_restart_CS), pointer :: & @@ -381,11 +383,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) - if (OS%use_waves) then - call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) - else - call MOM_wave_interface_init_lite(param_file) - endif + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initializes statistical waves. + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) if (associated(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & @@ -1042,24 +1042,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/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 index e675170575..e2a557daff 100644 --- a/config_src/drivers/mct_cap/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 @@ -1362,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/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 9561c87c9e..cf3928fc30 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -28,12 +28,12 @@ module MOM_cap_mod use MOM_get_input, only: get_MOM_input, directories use MOM_domains, only: pass_var use MOM_error_handler, only: MOM_error, FATAL, is_root_pe -use MOM_ocean_model_nuopc, only: ice_ocean_boundary_type use MOM_grid, only: ocean_grid_type, get_global_grid_size +use MOM_ocean_model_nuopc, only: ice_ocean_boundary_type use MOM_ocean_model_nuopc, only: ocean_model_restart, ocean_public_type, ocean_state_type use MOM_ocean_model_nuopc, only: ocean_model_init_sfc use MOM_ocean_model_nuopc, only: ocean_model_init, update_ocean_model, ocean_model_end -use MOM_ocean_model_nuopc, only: get_ocean_grid, get_eps_omesh +use MOM_ocean_model_nuopc, only: get_ocean_grid, get_eps_omesh, query_ocean_state use MOM_cap_time, only: AlarmInit use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype, mod2med_areacor use MOM_cap_methods, only: med2mod_areacor, state_diagnose @@ -423,6 +423,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) character(len=64) :: logmsg logical :: isPresent, isPresentDiro, isPresentLogfile, isSet logical :: existflag + logical :: use_waves ! If true, the wave modules are active. integer :: userRc integer :: localPet integer :: localPeCount @@ -697,8 +698,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary%lrunoff = 0.0 Ice_ocean_boundary%frunoff = 0.0 - if (ocean_state%use_waves) then - Ice_ocean_boundary%num_stk_bands=ocean_state%Waves%NumBands + call query_ocean_state(ocean_state, use_waves=use_waves) + if (use_waves) then + call query_ocean_state(ocean_state, NumWaveBands=Ice_ocean_boundary%num_stk_bands) allocate ( Ice_ocean_boundary% ustk0 (isc:iec,jsc:jec), & Ice_ocean_boundary% vstk0 (isc:iec,jsc:jec), & Ice_ocean_boundary% ustkb (isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & @@ -706,10 +708,12 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary%stk_wavenumbers (Ice_ocean_boundary%num_stk_bands)) Ice_ocean_boundary%ustk0 = 0.0 Ice_ocean_boundary%vstk0 = 0.0 - Ice_ocean_boundary%stk_wavenumbers = ocean_state%Waves%WaveNum_Cen + call query_ocean_state(ocean_state, WaveNumbers=Ice_ocean_boundary%stk_wavenumbers, unscale=.true.) Ice_ocean_boundary%ustkb = 0.0 Ice_ocean_boundary%vstkb = 0.0 endif + ! Consider adding this: + ! if (.not.use_waves) Ice_ocean_boundary%num_stk_bands = 0 ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_GridCompSetInternalState(gcomp, ocean_internalstate, rc) @@ -754,7 +758,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) !These are not currently used and changing requires a nuopc dictionary change !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_heat_flx" , "will provide") !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_heat_flx" , "will provide") - if (ocean_state%use_waves) then + if (use_waves) then if (Ice_ocean_boundary%num_stk_bands > 3) then call MOM_error(FATAL, "Number of Stokes Bands > 3, NUOPC cap not set up for this") endif diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 165c419c28..dd8f4d4580 100644 --- a/config_src/drivers/nuopc_cap/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 @@ -56,14 +57,15 @@ module MOM_ocean_model_nuopc use fms_mod, only : stdout use mpp_mod, only : mpp_chksum use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct -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 MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init +use MOM_wave_interface, only : Update_Surface_Waves, query_wave_properties use MOM_surface_forcing_nuopc, only : surface_forcing_init, convert_IOB_to_fluxes 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 MOM_domains, only : root_PE,num_PEs use MOM_coms, only : Get_PElist +use iso_fortran_env, only : int64 #include @@ -80,7 +82,7 @@ module MOM_ocean_model_nuopc public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum -public get_ocean_grid +public get_ocean_grid, query_ocean_state public get_eps_omesh !> This type is used for communication with other components via the FMS coupler. @@ -208,8 +210,8 @@ module MOM_ocean_model_nuopc type(marine_ice_CS), pointer :: & marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. - type(wave_parameters_cs), pointer, public :: & - Waves !< A structure containing pointers to the surface wave fields + type(wave_parameters_CS), pointer, public :: & + Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure type(MOM_restart_CS), pointer :: & @@ -390,14 +392,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) - if (OS%use_waves) then - call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) - call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",OS%Waves%WaveNum_Cen, & - "Central wavenumbers for surface Stokes drift bands.",units='rad/m', & - default=0.12566) - else - call MOM_wave_interface_init_lite(param_file) - endif + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initializes statistical waves. + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) if (associated(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & @@ -1019,6 +1016,31 @@ subroutine ocean_model_flux_init(OS, verbosity) end subroutine ocean_model_flux_init +!> This interface allows certain properties that are stored in the ocean_state_type to be +!! obtained. +subroutine query_ocean_state(OS, use_waves, NumWaveBands, Wavenumbers, unscale) + type(ocean_state_type), intent(in) :: OS !< The structure with the complete ocean state + logical, optional, intent(out) :: use_waves !< Indicates whether surface waves are in use + integer, optional, intent(out) :: NumWaveBands !< If present, this gives the number of + !! wavenumber partitions in the wave discretization + real, dimension(:), optional, intent(out) :: Wavenumbers !< If present, this gives the characteristic + !! wavenumbers of the wave discretization [m-1 or Z-1 ~> m-1] + logical, optional, intent(in) :: unscale !< If present and true, undo any dimensional + !! rescaling and return dimensional values in MKS units + + logical :: undo_scaling + undo_scaling = .false. ; if (present(unscale)) undo_scaling = unscale + + if (present(use_waves)) use_waves = OS%use_waves + if (present(NumWaveBands)) call query_wave_properties(OS%Waves, NumBands=NumWaveBands) + if (present(Wavenumbers) .and. undo_scaling) then + call query_wave_properties(OS%Waves, WaveNumbers=WaveNumbers, US=OS%US) + elseif (present(Wavenumbers)) then + call query_wave_properties(OS%Waves, WaveNumbers=WaveNumbers) + endif + +end subroutine query_ocean_state + !> Ocean_stock_pe - returns the integrated stocks of heat, water, etc. for conservation checks. !! Because of the way FMS is coded, only the root PE has the integrated amount, !! while all other PEs get 0. @@ -1061,26 +1083,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/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 7168823fbc..e8673da6f8 100644 --- a/config_src/drivers/nuopc_cap/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 @@ -1402,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/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 8edad7fa05..ebb953be93 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -65,7 +65,7 @@ program MOM_main use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type 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 MOM_wave_interface, only : Update_Surface_Waves use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS @@ -331,11 +331,9 @@ program MOM_main call get_param(param_file,mod_name, "USE_WAVES", Use_Waves, & "If true, enables surface wave modules.",default=.false.) - if (use_waves) then - call MOM_wave_interface_init(Time, grid, GV, US, param_file, Waves_CSp, diag) - else - call MOM_wave_interface_init_lite(param_file) - endif + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initializes statistical waves. + call MOM_wave_interface_init(Time, grid, GV, US, param_file, Waves_CSp, diag) segment_start_time = Time elapsed_time = 0.0 diff --git a/config_src/infra/FMS1/MOM_couplertype_infra.F90 b/config_src/infra/FMS1/MOM_couplertype_infra.F90 index fd947691ca..3bcccc1dc7 100644 --- a/config_src/infra/FMS1/MOM_couplertype_infra.F90 +++ b/config_src/infra/FMS1/MOM_couplertype_infra.F90 @@ -4,33 +4,36 @@ 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_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 +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_write_chksums -public :: CT_set_data, CT_increment_data -public :: CT_copy_data, CT_extract_data +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 +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_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 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 + 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. @@ -38,6 +41,36 @@ module MOM_couplertype_infra 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 @@ -83,6 +116,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 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 @@ -99,8 +150,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 CT_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 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 @@ -118,11 +221,59 @@ subroutine CT_copy_data(var_in, var, halo_size, bc_index, field_index, & 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 +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(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 @@ -132,11 +283,90 @@ subroutine CT_increment_data(var_in, var, halo_size, scale_factor, scale_prev) 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 +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) + 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 @@ -160,7 +390,7 @@ 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) + 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. @@ -185,6 +415,15 @@ subroutine CT_set_data(array_in, bc_index, field_index, var, & 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 @@ -205,14 +444,24 @@ subroutine CT_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) +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 +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) @@ -228,6 +477,13 @@ logical function CT_initialized_2d(var) 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 diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index fc39777a2f..029561946b 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -9,7 +9,7 @@ module MOM_domain_infra 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) @@ -1923,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/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 index ca5b2b8516..170573f7ec 100644 --- a/config_src/infra/FMS1/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/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index 3ea201235a..dcbd80e723 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -11,17 +11,19 @@ module MOM_io_infra 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_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_write_meta, mpp_write, mpp_read use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist use mpp_io_mod, only : mpp_get_axes, axistype, mpp_get_axis_data use mpp_io_mod, only : mpp_get_fields, fieldtype use mpp_io_mod, only : mpp_get_info, mpp_get_times use mpp_io_mod, only : mpp_io_init +use mpp_mod, only : stdout_if_root=>stdout ! 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 mpp_mod, only : lowercase use iso_fortran_env, only : int64 implicit none ; private @@ -32,6 +34,7 @@ module MOM_io_infra 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 +public :: stdout_if_root ! These types are inherited from underlying infrastructure code, to act as containers for ! information about fields and axes, respectively, and are opaque to this module. public :: fieldtype, axistype @@ -78,7 +81,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 +315,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 +330,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 @@ -415,7 +416,8 @@ 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) +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, & + global_file, file_may_be_4d) 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 @@ -424,8 +426,43 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom !! by before it is returned. type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. - if (present(MOM_Domain)) then + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data, file_is_global + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (.not.use_fms_read_data) then + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), data, timelevel) + exit + endif + enddo + + deallocate(fields) + call mpp_close(unit) + elseif (present(MOM_Domain)) then call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) else call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) @@ -439,7 +476,8 @@ 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) +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain, & + global_file, file_may_be_4d) 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 @@ -448,8 +486,46 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom !! by before they are returned. type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. - if (present(MOM_Domain)) then + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data, file_is_global + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (.not.use_fms_read_data) then + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 1-d variable "//trim(fieldname)//" from file "//trim(filename)) + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), data, timelevel) + exit + endif + enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "MOM_read_data apparently did not find 1-d variable "//trim(fieldname)//" in file "//trim(filename)) + + deallocate(fields) + call mpp_close(unit) + elseif (present(MOM_Domain)) then call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) else call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) @@ -465,7 +541,7 @@ end subroutine MOM_read_data_1d !! 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) + timelevel, position, scale, global_file, file_may_be_4d) 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 @@ -475,9 +551,49 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & 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. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data, file_is_global + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (use_fms_read_data) then + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + else + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 2-d variable "//trim(fieldname)//" from file "//trim(filename)) + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) + exit + endif + enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "MOM_read_data apparently did not find 2-d variable "//trim(fieldname)//" in file "//trim(filename)) + + deallocate(fields) + call mpp_close(unit) + endif if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) @@ -528,7 +644,7 @@ end subroutine MOM_read_data_2d_region !! 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) + timelevel, position, scale, global_file, file_may_be_4d) 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 @@ -538,9 +654,49 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & 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. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data, file_is_global + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (use_fms_read_data) then + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + else + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 3-d variable "//trim(fieldname)//" from file "//trim(filename)) + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) + exit + endif + enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "MOM_read_data apparently did not find 3-d variable "//trim(fieldname)//" in file "//trim(filename)) + + deallocate(fields) + call mpp_close(unit) + endif if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) @@ -552,7 +708,7 @@ end subroutine MOM_read_data_3d !! 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) + timelevel, position, scale, global_file) 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 @@ -562,9 +718,46 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & 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. + logical, optional, intent(in) :: global_file !< If true, read from a single global file - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data, file_is_global + integer :: n, unit, ndim, nvar, natt, ntime + integer :: is, ie, js, je + + ! This single call does not work for a 4-d array due to FMS limitations, so multiple calls are + ! needed. + ! call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + ! timelevel=timelevel, position=position) + + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 4-d variable "//trim(fieldname)//" from file "//trim(filename)) + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) + exit + endif + enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "MOM_read_data apparently did not find 4-d variable "//trim(fieldname)//" in file "//trim(filename)) + + deallocate(fields) + call mpp_close(unit) if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) @@ -683,7 +876,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 +890,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 +904,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 +917,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 +927,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 +943,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 +957,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 +967,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 +982,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/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..6f08065f57 --- /dev/null +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -0,0 +1,1956 @@ +!> 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 +use mpp_mod, only : stdout_if_root=>stdout +! 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 +public :: stdout_if_root +! 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 = "" + if (variable_att_exists(IO_handle%fileobj, var_names(i), "long_name")) & + call get_variable_attribute(IO_handle%fileobj, var_names(i), "long_name", longname) + fields(i)%longname = trim(longname) + units = "" + if (variable_att_exists(IO_handle%fileobj, var_names(i), "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, & + global_file, file_may_be_4d) + 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 + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. + + ! 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, & + global_file, file_may_be_4d) + 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 + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. + + ! 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, global_file, file_may_be_4d) + 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. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. + + ! 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, global_file, file_may_be_4d) + 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. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. + + ! 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, global_file) + 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. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + + + ! 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/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 4523f029bf..63f8193b33 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -263,8 +263,8 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) CS%id_v_preale = register_diag_field('ocean_model', 'v_preale', diag%axesCvL, Time, & 'Meridional velocity before remapping', 'm s-1', conversion=US%L_T_to_m_s) CS%id_h_preale = register_diag_field('ocean_model', 'h_preale', diag%axesTL, Time, & - 'Layer Thickness before remapping', get_thickness_units(GV), & - conversion=GV%H_to_MKS, v_extensive=.true.) + 'Layer Thickness before remapping', get_thickness_units(GV), conversion=GV%H_to_MKS, & + v_extensive=.true.) CS%id_T_preale = register_diag_field('ocean_model', 'T_preale', diag%axesTL, Time, & 'Temperature before remapping', 'degC') CS%id_S_preale = register_diag_field('ocean_model', 'S_preale', diag%axesTL, Time, & @@ -273,14 +273,13 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) 'Interface Heights before remapping', 'm', conversion=US%Z_to_m) CS%id_dzRegrid = register_diag_field('ocean_model','dzRegrid',diag%axesTi,Time, & - 'Change in interface height due to ALE regridding', 'm', & - conversion=GV%H_to_m) + 'Change in interface height due to ALE regridding', 'm', conversion=GV%H_to_m) cs%id_vert_remap_h = register_diag_field('ocean_model', 'vert_remap_h', & - diag%axestl, time, 'layer thicknesses after ALE regridding and remapping', 'm', & - conversion=GV%H_to_m, v_extensive=.true.) + diag%axestl, time, 'layer thicknesses after ALE regridding and remapping', & + 'm', conversion=GV%H_to_m, v_extensive=.true.) cs%id_vert_remap_h_tendency = register_diag_field('ocean_model','vert_remap_h_tendency',diag%axestl,time, & - 'Layer thicknesses tendency due to ALE regridding and remapping', 'm', & - conversion=GV%H_to_m*US%s_to_T, v_extensive = .true.) + 'Layer thicknesses tendency due to ALE regridding and remapping', & + 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive = .true.) end subroutine ALE_register_diags diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index d9c25d8cd1..2baac56599 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -4,7 +4,8 @@ module regrid_edge_values ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, FATAL -use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system +use regrid_solvers, only : solve_linear_system, linear_solver +use regrid_solvers, only : solve_tridiagonal_system, solve_diag_dominant_tridiag use polynomial_functions, only : evaluation_polynomial implicit none ; private @@ -16,8 +17,6 @@ module regrid_edge_values public edge_values_explicit_h2, edge_values_explicit_h4 public edge_values_implicit_h4, edge_values_implicit_h6 public edge_slopes_implicit_h3, edge_slopes_implicit_h5 -public solve_diag_dominant_tridiag -! public solve_diag_dominant_tridiag, linear_solver ! The following parameters are used to avoid singular matrices for boundary ! extrapolation. The are needed only in the case where thicknesses vanish @@ -1332,115 +1331,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_implicit_h6 -!> Solve the tridiagonal system AX = R -!! -!! This routine uses a variant of Thomas's algorithm to solve the tridiagonal system AX = R, in -!! a form that is guaranteed to avoid dividing by a zero pivot. The matrix A is made up of -!! lower (Al) and upper diagonals (Au) and a central diagonal Ad = Ac+Al+Au, where -!! Al, Au, and Ac are all positive (or negative) definite. However when Ac is smaller than -!! roundoff compared with (Al+Au), the answers are prone to inaccuracy. -subroutine solve_diag_dominant_tridiag( Al, Ac, Au, R, X, N ) - integer, intent(in) :: N !< The size of the system - real, dimension(N), intent(in) :: Ac !< Matrix center diagonal offset from Al + Au - real, dimension(N), intent(in) :: Al !< Matrix lower diagonal - real, dimension(N), intent(in) :: Au !< Matrix upper diagonal - real, dimension(N), intent(in) :: R !< system right-hand side - real, dimension(N), intent(out) :: X !< solution vector - ! Local variables - real, dimension(N) :: c1 ! Au / pivot for the backward sweep - real :: d1 ! The next value of 1.0 - c1 - real :: I_pivot ! The inverse of the most recent pivot - real :: denom_t1 ! The first term in the denominator of the inverse of the pivot. - integer :: k ! Loop index - - ! Factorization and forward sweep, in a form that will never give a division by a - ! zero pivot for positive definite Ac, Al, and Au. - I_pivot = 1.0 / (Ac(1) + Au(1)) - d1 = Ac(1) * I_pivot - c1(1) = Au(1) * I_pivot - X(1) = R(1) * I_pivot - do k=2,N-1 - denom_t1 = Ac(k) + d1 * Al(k) - I_pivot = 1.0 / (denom_t1 + Au(k)) - d1 = denom_t1 * I_pivot - c1(k) = Au(k) * I_pivot - X(k) = (R(k) - Al(k) * X(k-1)) * I_pivot - enddo - I_pivot = 1.0 / (Ac(N) + d1 * Al(N)) - X(N) = (R(N) - Al(N) * X(N-1)) * I_pivot - ! Backward sweep - do k=N-1,1,-1 - X(k) = X(k) - c1(k) * X(k+1) - enddo - -end subroutine solve_diag_dominant_tridiag - - -!> Solve the linear system AX = R by Gaussian elimination -!! -!! This routine uses Gauss's algorithm to transform the system's original -!! matrix into an upper triangular matrix. Back substitution then yields the answer. -!! The matrix A must be square, with the first index varing along the row. -subroutine linear_solver( N, A, R, X ) - integer, intent(in) :: N !< The size of the system - real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] - real, dimension(N), intent(inout) :: R !< system right-hand side [A] - real, dimension(N), intent(inout) :: X !< solution vector [A] - - ! Local variables - real :: factor ! The factor that eliminates the leading nonzero element in a row. - real :: I_pivot ! The reciprocal of the pivot value [inverse of the input units of a row of A] - real :: swap - integer :: i, j, k - - ! Loop on rows to transform the problem into multiplication by an upper-right matrix. - do i=1,N-1 - ! Seek a pivot for column i starting in row i, and continuing into the remaining rows. If the - ! pivot is in a row other than i, swap them. If no valid pivot is found, i = N+1 after this loop. - do k=i,N ; if ( abs(A(i,k)) > 0.0 ) exit ; enddo ! end loop to find pivot - if ( k > N ) then ! No pivot could be found and the system is singular. - write(0,*) ' A=',A - call MOM_error( FATAL, 'The linear system sent to linear_solver is singular.' ) - endif - - ! If the pivot is in a row that is different than row i, swap those two rows, noting that both - ! rows start with i-1 zero values. - if ( k /= i ) then - do j=i,N ; swap = A(j,i) ; A(j,i) = A(j,k) ; A(j,k) = swap ; enddo - swap = R(i) ; R(i) = R(k) ; R(k) = swap - endif - - ! Transform the pivot to 1 by dividing the entire row (right-hand side included) by the pivot - I_pivot = 1.0 / A(i,i) - A(i,i) = 1.0 - do j=i+1,N ; A(j,i) = A(j,i) * I_pivot ; enddo - R(i) = R(i) * I_pivot - - ! Put zeros in column for all rows below that contain the pivot (which is row i) - do k=i+1,N ! k is the row index - factor = A(i,k) - ! A(i,k) = 0.0 ! These elements are not used again, so this line can be skipped for speed. - do j=i+1,N ; A(j,k) = A(j,k) - factor * A(j,i) ; enddo - R(k) = R(k) - factor * R(i) - enddo - - enddo ! end loop on i - - ! Solve the system by back substituting into what is now an upper-right matrix. - if (A(N,N) == 0.0) then ! No pivot could be found and the system is singular. - ! write(0,*) ' A=',A - call MOM_error( FATAL, 'The final pivot in linear_solver is zero.' ) - endif - X(N) = R(N) / A(N,N) ! The last row can now be solved trivially. - do i=N-1,1,-1 ! loop on rows, starting from second to last row - X(i) = R(i) - do j=i+1,N ; X(i) = X(i) - A(j,i) * X(j) ; enddo - enddo - -end subroutine linear_solver - - - !> Test that A*C = R to within a tolerance, issuing a fatal error with an explanatory message if they do not. subroutine test_line(msg, N, A, C, R, mag, tol) real, intent(in) :: mag !< The magnitude of leading order terms in this line diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index 82b23832f4..50bd7f984d 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -155,6 +155,11 @@ subroutine linear_solver( N, A, R, X ) enddo ! end loop on i + if (A(N,N) == 0.0) then + ! no pivot could be found, and the sytem is singular + call MOM_error(FATAL, 'The final pivot in linear_solver is zero.') + end if + ! Solve the system by back substituting into what is now an upper-right matrix. X(N) = R(N) / A(N,N) ! The last row is now trivially solved. do i=N-1,1,-1 ! loop on rows, starting from second to last row diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3b6974ec1b..475e5a423f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -24,7 +24,8 @@ module MOM use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids use MOM_diag_mediator, only : diag_copy_storage_to_diag, diag_copy_diag_to_storage use MOM_domains, only : MOM_domains_init -use MOM_domains, only : sum_across_PEs, pass_var, pass_vector, clone_MOM_domain +use MOM_domains, only : sum_across_PEs, pass_var, pass_vector +use MOM_domains, only : clone_MOM_domain, deallocate_MOM_domain use MOM_domains, only : To_North, To_East, To_South, To_West use MOM_domains, only : To_All, Omit_corners, CGRID_NE, SCALAR_PAIR use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type @@ -41,7 +42,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(/) @@ -64,6 +65,7 @@ module MOM use MOM_diagnostics, only : register_surface_diags, write_static_fields use MOM_diagnostics, only : post_surface_dyn_diags, post_surface_thermo_diags use MOM_diagnostics, only : diagnostics_CS, surface_diag_IDs, transport_diag_IDs +use MOM_diagnostics, only : MOM_diagnostics_end use MOM_dynamics_unsplit, only : step_MOM_dyn_unsplit, register_restarts_dyn_unsplit use MOM_dynamics_unsplit, only : initialize_dyn_unsplit, end_dyn_unsplit use MOM_dynamics_unsplit, only : MOM_dyn_unsplit_CS @@ -84,9 +86,10 @@ module MOM use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_hor_index, only : rotate_hor_index use MOM_interface_heights, only : find_eta -use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init +use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init, VarMix_end use MOM_lateral_mixing_coeffs, only : calc_resoln_function, calc_depth_function, VarMix_CS -use MOM_MEKE, only : MEKE_init, MEKE_alloc_register_restart, step_forward_MEKE, MEKE_CS +use MOM_MEKE, only : MEKE_alloc_register_restart, step_forward_MEKE +use MOM_MEKE, only : MEKE_CS, MEKE_init, MEKE_end use MOM_MEKE_types, only : MEKE_type use MOM_mixed_layer_restrat, only : mixedlayer_restrat, mixedlayer_restrat_init, mixedlayer_restrat_CS use MOM_mixed_layer_restrat, only : mixedlayer_restrat_register_restarts @@ -96,14 +99,18 @@ module MOM use MOM_open_boundary, only : open_boundary_register_restarts use MOM_open_boundary, only : update_segment_tracer_reservoirs 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_viscous_BBL, set_viscous_ML use MOM_set_visc, only : set_visc_register_restarts, set_visc_CS +use MOM_set_visc, only : set_visc_init, set_visc_end +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 -use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS +use MOM_sum_output, only : MOM_sum_output_init, MOM_sum_output_end +use MOM_sum_output, only : sum_output_CS use MOM_ALE_sponge, only : init_ALE_sponge_diags, ALE_sponge_CS -use MOM_thickness_diffuse, only : thickness_diffuse, thickness_diffuse_init, thickness_diffuse_CS +use MOM_thickness_diffuse, only : thickness_diffuse, thickness_diffuse_init +use MOM_thickness_diffuse, only : thickness_diffuse_end, thickness_diffuse_CS use MOM_tracer_advect, only : advect_tracer, tracer_advect_init use MOM_tracer_advect, only : tracer_advect_end, tracer_advect_CS use MOM_tracer_hor_diff, only : tracer_hordiff, tracer_hor_diff_init @@ -1687,7 +1694,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. @@ -2044,11 +2051,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, & @@ -2146,8 +2148,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)") @@ -2183,7 +2184,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call MOM_timing_init(CS) - if (associated(CS%OBC)) call call_OBC_register(param_file, CS%update_OBC_CSp, CS%OBC) + if (associated(CS%OBC)) call call_OBC_register(param_file, CS%update_OBC_CSp, US, CS%OBC) call tracer_registry_init(param_file, CS%tracer_Reg) @@ -2210,11 +2211,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & conversion=US%Q_to_J_kg*CS%tv%C_p) endif if (CS%tv%S_is_absS) then - vd_S = var_desc(name="abssalt",units="g kg-1",longname="Absolute Salinity", & + vd_S = var_desc(name="abssalt", units="g kg-1", longname="Absolute Salinity", & cmor_field_name="so", cmor_longname="Sea Water Salinity", & conversion=0.001) else - vd_S = var_desc(name="salt",units="psu",longname="Salinity", & + vd_S = var_desc(name="salt", units="psu", longname="Salinity", & cmor_field_name="so", cmor_longname="Sea Water Salinity", & conversion=0.001) endif @@ -2351,17 +2352,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: @@ -2376,10 +2366,27 @@ 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) ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. @@ -2859,9 +2866,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 @@ -2883,15 +2890,9 @@ subroutine register_diags(Time, G, GV, US, IDs, diag) type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output - real :: H_convert character(len=48) :: thickness_units thickness_units = get_thickness_units(GV) - if (GV%Boussinesq) then - H_convert = GV%H_to_m - else - H_convert = GV%H_to_kg_m2 - endif ! Diagnostics of the rapidly varying dynamic state IDs%id_u = register_diag_field('ocean_model', 'u_dyn', diag%axesCuL, Time, & @@ -2899,8 +2900,8 @@ subroutine register_diags(Time, G, GV, US, IDs, diag) IDs%id_v = register_diag_field('ocean_model', 'v_dyn', diag%axesCvL, Time, & 'Meridional velocity after the dynamics update', 'm s-1', conversion=US%L_T_to_m_s) IDs%id_h = register_diag_field('ocean_model', 'h_dyn', diag%axesTL, Time, & - 'Layer Thickness after the dynamics update', thickness_units, & - v_extensive=.true., conversion=H_convert) + 'Layer Thickness after the dynamics update', thickness_units, conversion=GV%H_to_MKS, & + v_extensive=.true.) IDs%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, & Time, 'Instantaneous Sea Surface Height', 'm') end subroutine register_diags @@ -3546,28 +3547,28 @@ end subroutine get_ocean_stocks subroutine MOM_end(CS) type(MOM_control_struct), pointer :: CS !< MOM control structure - if (CS%use_ALE_algorithm) call ALE_end(CS%ALE_CSp) + call MOM_sum_output_end(CS%sum_output_CSp) - DEALLOC_(CS%u) ; DEALLOC_(CS%v) ; DEALLOC_(CS%h) - DEALLOC_(CS%uh) ; DEALLOC_(CS%vh) + if (CS%use_ALE_algorithm) call ALE_end(CS%ALE_CSp) - if (associated(CS%tv%T)) then - DEALLOC_(CS%T) ; CS%tv%T => NULL() ; DEALLOC_(CS%S) ; CS%tv%S => NULL() - endif - if (associated(CS%tv%frazil)) deallocate(CS%tv%frazil) - if (associated(CS%tv%salt_deficit)) deallocate(CS%tv%salt_deficit) - if (associated(CS%Hml)) deallocate(CS%Hml) + ! NOTE: Allocated in PressureForce_FV_Bouss + if (associated(CS%tv%varT)) deallocate(CS%tv%varT) call tracer_advect_end(CS%tracer_adv_CSp) call tracer_hor_diff_end(CS%tracer_diff_CSp) call tracer_registry_end(CS%tracer_Reg) call tracer_flow_control_end(CS%tracer_flow_CSp) - call diabatic_driver_end(CS%diabatic_CSp) + if (.not. CS%adiabatic) then + call diabatic_driver_end(CS%diabatic_CSp) + deallocate(CS%diabatic_CSp) + endif + + call MOM_diagnostics_end(CS%diagnostics_CSp, CS%ADp, CS%CDp) + deallocate(CS%diagnostics_CSp) if (CS%offline_tracer_mode) call offline_transport_end(CS%offline_CSp) - DEALLOC_(CS%uhtr) ; DEALLOC_(CS%vhtr) if (CS%split) then call end_dyn_split_RK2(CS%dyn_split_RK2_CSp) elseif (CS%use_RK2) then @@ -3575,15 +3576,63 @@ subroutine MOM_end(CS) else call end_dyn_unsplit(CS%dyn_unsplit_CSp) endif + + call thickness_diffuse_end(CS%thickness_diffuse_CSp, CS%CDp) + deallocate(CS%thickness_diffuse_CSp) + + if (associated(CS%VarMix)) then + call VarMix_end(CS%VarMix) + deallocate(CS%VarMix) + endif + + if (associated(CS%mixedlayer_restrat_CSp)) & + deallocate(CS%mixedlayer_restrat_CSp) + + if (associated(CS%set_visc_CSp)) & + call set_visc_end(CS%visc, CS%set_visc_CSp) + + if (associated(CS%MEKE_CSp)) deallocate(CS%MEKE_CSp) + + if (associated(CS%MEKE)) then + call MEKE_end(CS%MEKE) + deallocate(CS%MEKE) + endif + + if (associated(CS%tv%internal_heat)) deallocate(CS%tv%internal_heat) + if (associated(CS%tv%TempxPmE)) deallocate(CS%tv%TempxPmE) + DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) + + ! TODO: debug_truncations deallocation + + DEALLOC_(CS%uhtr) ; DEALLOC_(CS%vhtr) + + if (associated(CS%Hml)) deallocate(CS%Hml) + if (associated(CS%tv%salt_deficit)) deallocate(CS%tv%salt_deficit) + if (associated(CS%tv%frazil)) deallocate(CS%tv%frazil) + + if (associated(CS%tv%T)) then + DEALLOC_(CS%T) ; CS%tv%T => NULL() ; DEALLOC_(CS%S) ; CS%tv%S => NULL() + endif + + DEALLOC_(CS%u) ; DEALLOC_(CS%v) ; DEALLOC_(CS%h) + DEALLOC_(CS%uh) ; DEALLOC_(CS%vh) + if (associated(CS%update_OBC_CSp)) call OBC_register_end(CS%update_OBC_CSp) call verticalGridEnd(CS%GV) call unit_scaling_end(CS%US) call MOM_grid_end(CS%G) - deallocate(CS) + if (CS%debug .or. CS%G%symmetric) & + call deallocate_MOM_domain(CS%G%Domain_aux) + if (CS%rotate_index) & + call deallocate_MOM_domain(CS%G%Domain) + + call deallocate_MOM_domain(CS%G_in%domain) + + deallocate(CS) end subroutine MOM_end !> \namespace mom diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 7cbc1eb262..e4d97ab53a 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -79,6 +79,8 @@ module MOM_CoriolisAdv 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_h_gKEu = -1, id_h_gKEv = -1 + integer :: id_h_rvxu = -1, id_h_rvxv = -1 integer :: id_intz_rvxu_2d = -1, id_intz_rvxv_2d = -1 !>@} end type CoriolisAdv_CS @@ -170,6 +172,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]. @@ -179,7 +182,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. @@ -191,8 +195,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]. @@ -228,9 +232,13 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) ! 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 thickness multiplied momentum budget terms + real, allocatable, dimension(:,:,:) :: h_gKEu, h_gKEv ! h x gKEu, h x gKEv [H L T-2 ~> m2 s-2]. + real, allocatable, dimension(:,:,:) :: h_rvxv, h_rvxu ! h x rvxv, h x rvxu [H L T-2 ~> m2 s-2]. + ! 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]. + real, dimension(SZIB_(G),SZJ_(G)) :: intz_gKEu_2d, intz_rvxv_2d ! [H L T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJB_(G)) :: intz_gKEv_2d, intz_rvxu_2d ! [H L 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: @@ -241,7 +249,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. @@ -277,7 +285,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, @@ -295,6 +303,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)) @@ -428,45 +437,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. @@ -671,27 +679,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 @@ -782,21 +794,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. @@ -942,6 +961,44 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) deallocate(hf_rvxu_2d) endif + if (CS%id_h_gKEu > 0) then + allocate(h_gKEu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_gKEu(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_gKEu(I,j,k) = AD%gradKEu(I,j,k) * AD%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_gKEu, h_gKEu, CS%diag) + deallocate(h_gKEu) + endif + if (CS%id_h_gKEv > 0) then + allocate(h_gKEv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_gKEv(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_gKEv(i,J,k) = AD%gradKEv(i,J,k) * AD%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_gKEv, h_gKEv, CS%diag) + deallocate(h_gKEv) + endif + + if (CS%id_h_rvxv > 0) then + allocate(h_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_rvxv(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_rvxv(I,j,k) = AD%rv_x_v(I,j,k) * AD%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_rvxv, h_rvxv, CS%diag) + deallocate(h_rvxv) + endif + if (CS%id_h_rvxu > 0) then + allocate(h_rvxu(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_rvxu(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_rvxu(i,J,k) = AD%rv_x_u(i,J,k) * AD%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_rvxu, h_rvxu, CS%diag) + deallocate(h_rvxu) + 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 @@ -1249,6 +1306,14 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,JsdB,JedB,nz) endif + CS%id_h_gKEu = register_diag_field('ocean_model', 'h_gKEu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Grad. Kinetic Energy', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_gKEu > 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_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) @@ -1257,6 +1322,14 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hu,IsdB,IedB,jsd,jed,nz) endif + CS%id_h_gKEv = register_diag_field('ocean_model', 'h_gKEv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Grad. Kinetic Energy', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_gKEv > 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_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) @@ -1297,6 +1370,14 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) endif + CS%id_h_rvxu = register_diag_field('ocean_model', 'h_rvxu', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Relative Vorticity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_rvxu > 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_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) @@ -1305,6 +1386,14 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hv,isd,ied,JsdB,JedB,nz) endif + CS%id_h_rvxv = register_diag_field('ocean_model', 'h_rvxv', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Relative Vorticity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_rvxv > 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 + 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) @@ -1317,8 +1406,7 @@ end subroutine CoriolisAdv_init !> Destructor for coriolisadv_cs subroutine CoriolisAdv_end(CS) - type(CoriolisAdv_CS), pointer :: CS !< Control structure fro MOM_CoriolisAdv - deallocate(CS) + type(CoriolisAdv_CS), intent(inout) :: CS !< Control structure fro MOM_CoriolisAdv end subroutine CoriolisAdv_end !> \namespace mom_coriolisadv diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index b4da255ddb..2316bb9725 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -120,15 +120,13 @@ end subroutine PressureForce_init !> Deallocate the pressure force control structure subroutine PressureForce_end(CS) - type(PressureForce_CS), pointer :: CS !< Pressure force control structure + type(PressureForce_CS), intent(inout) :: CS !< Pressure force control structure if (CS%Analytic_FV_PGF) then call PressureForce_FV_end(CS%PressureForce_FV_CSp) else call PressureForce_Mont_end(CS%PressureForce_Mont_CSp) endif - - if (associated(CS)) deallocate(CS) end subroutine PressureForce_end !> \namespace mom_pressureforce diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 17e7ebee40..51f9a5cb85 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -7,10 +7,10 @@ module MOM_barotropic use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, enable_averaging -use MOM_domains, only : min_across_PEs, clone_MOM_domain, pass_vector +use MOM_domains, only : min_across_PEs, clone_MOM_domain, deallocate_MOM_domain use MOM_domains, only : To_All, Scalar_Pair, AGRID, CORNER, MOM_domain_type use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_domains, only : start_group_pass, complete_group_pass, pass_var +use MOM_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing @@ -4797,13 +4797,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'Barotropic meridional acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_eta_bt = register_diag_field('ocean_model', 'eta_bt', diag%axesT1, Time, & - 'Barotropic end SSH', thickness_units, conversion=GV%H_to_m) + 'Barotropic end SSH', thickness_units, conversion=GV%H_to_MKS) CS%id_ubt = register_diag_field('ocean_model', 'ubt', diag%axesCu1, Time, & 'Barotropic end zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vbt = register_diag_field('ocean_model', 'vbt', diag%axesCv1, Time, & 'Barotropic end meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_eta_st = register_diag_field('ocean_model', 'eta_st', diag%axesT1, Time, & - 'Barotropic start SSH', thickness_units, conversion=GV%H_to_m) + 'Barotropic start SSH', thickness_units, conversion=GV%H_to_MKS) CS%id_ubt_st = register_diag_field('ocean_model', 'ubt_st', diag%axesCu1, Time, & 'Barotropic start zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vbt_st = register_diag_field('ocean_model', 'vbt_st', diag%axesCv1, Time, & @@ -4813,7 +4813,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_vbtav = register_diag_field('ocean_model', 'vbtav', diag%axesCv1, Time, & 'Barotropic time-average meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_eta_cor = register_diag_field('ocean_model', 'eta_cor', diag%axesT1, Time, & - 'Corrective mass flux', 'm s-1', conversion=GV%H_to_m) + 'Corrective mass flux within a timestep', 'm', conversion=GV%H_to_m) CS%id_visc_rem_u = register_diag_field('ocean_model', 'visc_rem_u', diag%axesCuL, Time, & 'Viscous remnant at u', 'nondim') CS%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, Time, & @@ -4827,20 +4827,19 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_gtotw = register_diag_field('ocean_model', 'gtot_w', diag%axesT1, Time, & 'gtot to West', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) CS%id_eta_hifreq = register_diag_field('ocean_model', 'eta_hifreq', diag%axesT1, Time, & - 'High Frequency Barotropic SSH', thickness_units, conversion=GV%H_to_m) + 'High Frequency Barotropic SSH', thickness_units, conversion=GV%H_to_MKS) CS%id_ubt_hifreq = register_diag_field('ocean_model', 'ubt_hifreq', diag%axesCu1, Time, & 'High Frequency Barotropic zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vbt_hifreq = register_diag_field('ocean_model', 'vbt_hifreq', diag%axesCv1, Time, & 'High Frequency Barotropic meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, Time, & - 'High Frequency Predictor Barotropic SSH', thickness_units, & - conversion=GV%H_to_m) + 'High Frequency Predictor Barotropic SSH', thickness_units, conversion=GV%H_to_MKS) CS%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, Time, & - 'High Frequency Barotropic zonal transport', 'm3 s-1', & - conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + 'High Frequency Barotropic zonal transport', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) CS%id_vhbt_hifreq = register_diag_field('ocean_model', 'vhbt_hifreq', diag%axesCv1, Time, & - 'High Frequency Barotropic meridional transport', 'm3 s-1', & - conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + 'High Frequency Barotropic meridional transport', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) CS%id_frhatu = register_diag_field('ocean_model', 'frhatu', diag%axesCuL, Time, & 'Fractional thickness of layers in u-columns', 'nondim') CS%id_frhatv = register_diag_field('ocean_model', 'frhatv', diag%axesCvL, Time, & @@ -4850,11 +4849,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_frhatv1 = register_diag_field('ocean_model', 'frhatv1', diag%axesCvL, Time, & 'Predictor Fractional thickness of layers in v-columns', 'nondim') CS%id_uhbt = register_diag_field('ocean_model', 'uhbt', diag%axesCu1, Time, & - 'Barotropic zonal transport averaged over a baroclinic step', 'm3 s-1', & - conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + 'Barotropic zonal transport averaged over a baroclinic step', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) CS%id_vhbt = register_diag_field('ocean_model', 'vhbt', diag%axesCv1, Time, & - 'Barotropic meridional transport averaged over a baroclinic step', 'm3 s-1', & - conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + 'Barotropic meridional transport averaged over a baroclinic step', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) if (use_BT_cont_type) then CS%id_BTC_FA_u_EE = register_diag_field('ocean_model', 'BTC_FA_u_EE', diag%axesCu1, Time, & @@ -4999,19 +4998,25 @@ end subroutine barotropic_get_tav !> Clean up the barotropic control structure. subroutine barotropic_end(CS) - type(barotropic_CS), pointer :: CS !< Control structure to clear out. - DEALLOC_(CS%frhatu) ; DEALLOC_(CS%frhatv) - DEALLOC_(CS%IDatu) ; DEALLOC_(CS%IDatv) - DEALLOC_(CS%ubtav) ; DEALLOC_(CS%vbtav) - DEALLOC_(CS%eta_cor) + type(barotropic_CS), intent(inout) :: CS !< Control structure to clear out. + + call destroy_BT_OBC(CS%BT_OBC) + + ! Allocated in barotropic_init, called in timestep initialization DEALLOC_(CS%ua_polarity) ; DEALLOC_(CS%va_polarity) + DEALLOC_(CS%IDatu) ; DEALLOC_(CS%IDatv) if (CS%bound_BT_corr) then DEALLOC_(CS%eta_cor_bound) endif + DEALLOC_(CS%eta_cor) + DEALLOC_(CS%frhatu) ; DEALLOC_(CS%frhatv) - call destroy_BT_OBC(CS%BT_OBC) + if (associated(CS%frhatu1)) deallocate(CS%frhatu1) + if (associated(CS%frhatv1)) deallocate(CS%frhatv1) + call deallocate_MOM_domain(CS%BT_domain) - deallocate(CS) + ! Allocated in restart registration, prior to timestep initialization + DEALLOC_(CS%ubtav) ; DEALLOC_(CS%vbtav) end subroutine barotropic_end !> This subroutine is used to register any fields from MOM_barotropic.F90 diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 17712491c4..2e25af2460 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -58,9 +58,10 @@ module MOM_boundary_update !> The following subroutines and associated definitions provide the !! machinery to register and call the subroutines that initialize !! open boundary conditions. -subroutine call_OBC_register(param_file, CS, OBC) +subroutine call_OBC_register(param_file, CS, US, OBC) type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(update_OBC_CS), pointer :: CS !< Control structure for OBCs + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< Open boundary structure ! Local variables @@ -92,19 +93,19 @@ subroutine call_OBC_register(param_file, CS, OBC) default=.false.) if (CS%use_files) CS%use_files = & - register_file_OBC(param_file, CS%file_OBC_CSp, & + register_file_OBC(param_file, CS%file_OBC_CSp, US, & OBC%OBC_Reg) if (CS%use_tidal_bay) CS%use_tidal_bay = & - register_tidal_bay_OBC(param_file, CS%tidal_bay_OBC_CSp, & + register_tidal_bay_OBC(param_file, CS%tidal_bay_OBC_CSp, US, & OBC%OBC_Reg) if (CS%use_Kelvin) CS%use_Kelvin = & - register_Kelvin_OBC(param_file, CS%Kelvin_OBC_CSp, & + register_Kelvin_OBC(param_file, CS%Kelvin_OBC_CSp, US, & OBC%OBC_Reg) if (CS%use_shelfwave) CS%use_shelfwave = & - register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, & + register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, US, & OBC%OBC_Reg) if (CS%use_dyed_channel) CS%use_dyed_channel = & - register_dyed_channel_OBC(param_file, CS%dyed_channel_OBC_CSp, & + register_dyed_channel_OBC(param_file, CS%dyed_channel_OBC_CSp, US, & OBC%OBC_Reg) end subroutine call_OBC_register @@ -128,7 +129,7 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) if (CS%use_Kelvin) & call Kelvin_set_OBC_data(OBC, CS%Kelvin_OBC_CSp, G, GV, US, h, Time) if (CS%use_shelfwave) & - call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, h, Time) + call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, US, h, Time) if (CS%use_dyed_channel) & call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, Time) if (OBC%needs_IO_for_data .or. OBC%add_tide_constituents) & diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index 1ad37a82b8..480568c545 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -167,14 +167,11 @@ end function continuity_stencil !> Destructor for continuity_cs. subroutine continuity_end(CS) - type(continuity_CS), pointer :: CS !< Control structure for mom_continuity. + type(continuity_CS), intent(inout) :: CS !< Control structure for mom_continuity. if (CS%continuity_scheme == PPM_SCHEME) then call continuity_PPM_end(CS%PPM_CSp) endif - - deallocate(CS) - end subroutine continuity_end end module MOM_continuity diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 7b90297c64..d8b6cddaaa 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -430,7 +430,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & if (present(uhbt)) then call zonal_flux_adjust(u, h_in, h_L, h_R, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I, .true., uh, OBC=OBC) + j, ish, ieh, do_I, uh, OBC=OBC) if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo @@ -710,7 +710,7 @@ end subroutine zonal_face_thickness !! desired barotropic (layer-summed) transport. subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & du, du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I_in, full_precision, uh_3d, OBC) + j, ish, ieh, do_I_in, uh_3d, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -746,9 +746,6 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & integer, intent(in) :: ieh !< End of index range. logical, dimension(SZIB_(G)), intent(in) :: do_I_in !< !! A logical flag indicating which I values to work on. - logical, optional, intent(in) :: full_precision !< - !! A flag indicating how carefully to iterate. The - !! default is .true. (more accurate). real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: uh_3d !< !! Volume flux through zonal faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. @@ -768,10 +765,9 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1]. integer :: i, k, nz, itt, max_itts = 20 - logical :: full_prec, domore, do_I(SZIB_(G)) + logical :: domore, do_I(SZIB_(G)) nz = GV%ke - full_prec = .true. ; if (present(full_precision)) full_prec = full_precision uh_aux(:,:) = 0.0 ; duhdu(:,:) = 0.0 @@ -787,16 +783,12 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & enddo do itt=1,max_itts - if (full_prec) then - select case (itt) - case (:1) ; tol_eta = 1e-6 * CS%tol_eta - case (2) ; tol_eta = 1e-4 * CS%tol_eta - case (3) ; tol_eta = 1e-2 * CS%tol_eta - case default ; tol_eta = CS%tol_eta - end select - else - tol_eta = CS%tol_eta_aux ; if (itt<=1) tol_eta = 1e-6 * CS%tol_eta_aux - endif + select case (itt) + case (:1) ; tol_eta = 1e-6 * CS%tol_eta + case (2) ; tol_eta = 1e-4 * CS%tol_eta + case (3) ; tol_eta = 1e-2 * CS%tol_eta + case default ; tol_eta = CS%tol_eta + end select tol_vel = CS%tol_vel do I=ish-1,ieh @@ -809,30 +801,23 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & if ((dt * min(G%IareaT(i,j),G%IareaT(i+1,j))*abs(uh_err(I)) > tol_eta) .or. & (CS%better_iter .and. ((abs(uh_err(I)) > tol_vel * duhdu_tot(I)) .or. & (abs(uh_err(I)) > uh_err_best(I))) )) then - ! Use Newton's method, provided it stays bounded. Otherwise bisect - ! the value with the appropriate bound. - if (full_prec) then - ddu = -uh_err(I) / duhdu_tot(I) - du_prev = du(I) - du(I) = du(I) + ddu - if (abs(ddu) < 1.0e-15*abs(du(I))) then - do_I(I) = .false. ! ddu is small enough to quit. - elseif (ddu > 0.0) then - if (du(I) >= du_max(I)) then - du(I) = 0.5*(du_prev + du_max(I)) - if (du_max(I) - du_prev < 1.0e-15*abs(du(I))) do_I(I) = .false. - endif - else ! ddu < 0.0 - if (du(I) <= du_min(I)) then - du(I) = 0.5*(du_prev + du_min(I)) - if (du_prev - du_min(I) < 1.0e-15*abs(du(I))) do_I(I) = .false. - endif + ! Use Newton's method, provided it stays bounded. Otherwise bisect + ! the value with the appropriate bound. + ddu = -uh_err(I) / duhdu_tot(I) + du_prev = du(I) + du(I) = du(I) + ddu + if (abs(ddu) < 1.0e-15*abs(du(I))) then + do_I(I) = .false. ! ddu is small enough to quit. + elseif (ddu > 0.0) then + if (du(I) >= du_max(I)) then + du(I) = 0.5*(du_prev + du_max(I)) + if (du_max(I) - du_prev < 1.0e-15*abs(du(I))) do_I(I) = .false. + endif + else ! ddu < 0.0 + if (du(I) <= du_min(I)) then + du(I) = 0.5*(du_prev + du_min(I)) + if (du_prev - du_min(I) < 1.0e-15*abs(du(I))) do_I(I) = .false. endif - else - ! Use Newton's method, provided it stays bounded, just like above. - du(I) = du(I) - uh_err(I) / duhdu_tot(I) - if ((du(I) >= du_max(I)) .or. (du(I) <= du_min(I))) & - du(I) = 0.5*(du_max(I) + du_min(I)) endif if (do_I(I)) domore = .true. else @@ -950,7 +935,7 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, do I=ish-1,ieh ; zeros(I) = 0.0 ; enddo call zonal_flux_adjust(u, h_in, h_L, h_R, zeros, uh_tot_0, duhdu_tot_0, du0, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I, .true.) + j, ish, ieh, do_I) ! Determine the westerly- and easterly- fluxes. Choose a sufficiently ! negative velocity correction for the easterly-flux, and a sufficiently @@ -1253,7 +1238,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & if (present(vhbt)) then call meridional_flux_adjust(v, h_in, h_L, h_R, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I, .true., vh, OBC=OBC) + j, ish, ieh, do_I, vh, OBC=OBC) if (present(v_cor)) then ; do k=1,nz do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo @@ -1537,7 +1522,7 @@ end subroutine merid_face_thickness !> Returns the barotropic velocity adjustment that gives the desired barotropic (layer-summed) transport. subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0, & dv, dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I_in, full_precision, vh_3d, OBC) + j, ish, ieh, do_I_in, vh_3d, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -1572,8 +1557,6 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 integer, intent(in) :: ieh !< End of index range. logical, dimension(SZI_(G)), & intent(in) :: do_I_in !< A flag indicating which I values to work on. - logical, optional, intent(in) :: full_precision !< A flag indicating how carefully to - !! iterate. The default is .true. (more accurate). real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(inout) :: vh_3d !< Volume flux through meridional !! faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -1594,10 +1577,9 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1]. integer :: i, k, nz, itt, max_itts = 20 - logical :: full_prec, domore, do_I(SZI_(G)) + logical :: domore, do_I(SZI_(G)) nz = GV%ke - full_prec = .true. ; if (present(full_precision)) full_prec = full_precision vh_aux(:,:) = 0.0 ; dvhdv(:,:) = 0.0 @@ -1613,16 +1595,12 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 enddo do itt=1,max_itts - if (full_prec) then - select case (itt) - case (:1) ; tol_eta = 1e-6 * CS%tol_eta - case (2) ; tol_eta = 1e-4 * CS%tol_eta - case (3) ; tol_eta = 1e-2 * CS%tol_eta - case default ; tol_eta = CS%tol_eta - end select - else - tol_eta = CS%tol_eta_aux ; if (itt<=1) tol_eta = 1e-6 * CS%tol_eta_aux - endif + select case (itt) + case (:1) ; tol_eta = 1e-6 * CS%tol_eta + case (2) ; tol_eta = 1e-4 * CS%tol_eta + case (3) ; tol_eta = 1e-2 * CS%tol_eta + case default ; tol_eta = CS%tol_eta + end select tol_vel = CS%tol_vel do i=ish,ieh @@ -1637,28 +1615,21 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 (abs(vh_err(i)) > vh_err_best(i))) )) then ! Use Newton's method, provided it stays bounded. Otherwise bisect ! the value with the appropriate bound. - if (full_prec) then - ddv = -vh_err(i) / dvhdv_tot(i) - dv_prev = dv(i) - dv(i) = dv(i) + ddv - if (abs(ddv) < 1.0e-15*abs(dv(i))) then - do_I(i) = .false. ! ddv is small enough to quit. - elseif (ddv > 0.0) then - if (dv(i) >= dv_max(i)) then - dv(i) = 0.5*(dv_prev + dv_max(i)) - if (dv_max(i) - dv_prev < 1.0e-15*abs(dv(i))) do_I(i) = .false. - endif - else ! dvv(i) < 0.0 - if (dv(i) <= dv_min(i)) then - dv(i) = 0.5*(dv_prev + dv_min(i)) - if (dv_prev - dv_min(i) < 1.0e-15*abs(dv(i))) do_I(i) = .false. - endif + ddv = -vh_err(i) / dvhdv_tot(i) + dv_prev = dv(i) + dv(i) = dv(i) + ddv + if (abs(ddv) < 1.0e-15*abs(dv(i))) then + do_I(i) = .false. ! ddv is small enough to quit. + elseif (ddv > 0.0) then + if (dv(i) >= dv_max(i)) then + dv(i) = 0.5*(dv_prev + dv_max(i)) + if (dv_max(i) - dv_prev < 1.0e-15*abs(dv(i))) do_I(i) = .false. + endif + else ! dvv(i) < 0.0 + if (dv(i) <= dv_min(i)) then + dv(i) = 0.5*(dv_prev + dv_min(i)) + if (dv_prev - dv_min(i) < 1.0e-15*abs(dv(i))) do_I(i) = .false. endif - else - ! Use Newton's method, provided it stays bounded, just like above. - dv(i) = dv(i) - vh_err(i) / dvhdv_tot(i) - if ((dv(i) >= dv_max(i)) .or. (dv(i) <= dv_min(i))) & - dv(i) = 0.5*(dv_max(i) + dv_min(i)) endif if (do_I(i)) domore = .true. else @@ -1776,7 +1747,7 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, do i=ish,ieh ; zeros(i) = 0.0 ; enddo call meridional_flux_adjust(v, h_in, h_L, h_R, zeros, vh_tot_0, dvhdv_tot_0, dv0, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I, .true.) + j, ish, ieh, do_I) ! Determine the southerly- and northerly- fluxes. Choose a sufficiently ! negative velocity correction for the northerly-flux, and a sufficiently @@ -1871,10 +1842,10 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness !! that can be obtained by a concave parabolic fit. - logical, optional, intent(in) :: monotonic !< If true, use the + logical, intent(in) :: monotonic !< If true, use the !! Colella & Woodward monotonic limiter. !! Otherwise use a simple positive-definite limiter. - logical, optional, intent(in) :: simple_2nd !< If true, use the + logical, intent(in) :: simple_2nd !< If true, use the !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. @@ -1884,15 +1855,11 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ real, parameter :: oneSixth = 1./6. real :: h_ip1, h_im1 real :: dMx, dMn - logical :: use_CW84, use_2nd character(len=256) :: mesg integer :: i, j, isl, iel, jsl, jel, n, stencil logical :: local_open_BC type(OBC_segment_type), pointer :: segment => NULL() - use_CW84 = .false. ; if (present(monotonic)) use_CW84 = monotonic - use_2nd = .false. ; if (present(simple_2nd)) use_2nd = simple_2nd - local_open_BC = .false. if (present(OBC)) then ; if (associated(OBC)) then local_open_BC = OBC%open_u_BCs_exist_globally @@ -1901,7 +1868,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ isl = LB%ish-1 ; iel = LB%ieh+1 ; jsl = LB%jsh ; jel = LB%jeh ! This is the stencil of the reconstruction, not the scheme overall. - stencil = 2 ; if (use_2nd) stencil = 1 + stencil = 2 ; if (simple_2nd) stencil = 1 if ((isl-stencil < G%isd) .or. (iel+stencil > G%ied)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_x called with a ", & @@ -1916,7 +1883,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ call MOM_error(FATAL,mesg) endif - if (use_2nd) then + if (simple_2nd) then do j=jsl,jel ; do i=isl,iel h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j) h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j) @@ -1990,7 +1957,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ enddo endif - if (use_CW84) then + if (monotonic) then call PPM_limit_CW84(h_in, h_L, h_R, G, isl, iel, jsl, jel) else call PPM_limit_pos(h_in, h_L, h_R, h_min, G, isl, iel, jsl, jel) @@ -2010,10 +1977,10 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness !! that can be obtained by a concave parabolic fit. - logical, optional, intent(in) :: monotonic !< If true, use the + logical, intent(in) :: monotonic !< If true, use the !! Colella & Woodward monotonic limiter. !! Otherwise use a simple positive-definite limiter. - logical, optional, intent(in) :: simple_2nd !< If true, use the + logical, intent(in) :: simple_2nd !< If true, use the !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. @@ -2023,15 +1990,11 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ real, parameter :: oneSixth = 1./6. real :: h_jp1, h_jm1 real :: dMx, dMn - logical :: use_CW84, use_2nd character(len=256) :: mesg integer :: i, j, isl, iel, jsl, jel, n, stencil logical :: local_open_BC type(OBC_segment_type), pointer :: segment => NULL() - use_CW84 = .false. ; if (present(monotonic)) use_CW84 = monotonic - use_2nd = .false. ; if (present(simple_2nd)) use_2nd = simple_2nd - local_open_BC = .false. if (present(OBC)) then ; if (associated(OBC)) then local_open_BC = OBC%open_v_BCs_exist_globally @@ -2040,7 +2003,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ isl = LB%ish ; iel = LB%ieh ; jsl = LB%jsh-1 ; jel = LB%jeh+1 ! This is the stencil of the reconstruction, not the scheme overall. - stencil = 2 ; if (use_2nd) stencil = 1 + stencil = 2 ; if (simple_2nd) stencil = 1 if ((isl < G%isd) .or. (iel > G%ied)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_y called with a ", & @@ -2055,7 +2018,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ call MOM_error(FATAL,mesg) endif - if (use_2nd) then + if (simple_2nd) then do j=jsl,jel ; do i=isl,iel h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j) h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j) @@ -2127,7 +2090,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ enddo endif - if (use_CW84) then + if (monotonic) then call PPM_limit_CW84(h_in, h_L, h_R, G, isl, iel, jsl, jel) else call PPM_limit_pos(h_in, h_L, h_R, h_min, G, isl, iel, jsl, jel) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index ef7da5c291..291703a242 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -36,27 +36,33 @@ module MOM_dynamics_split_RK2 use MOM_ALE, only : ALE_CS use MOM_barotropic, only : barotropic_init, btstep, btcalc, bt_mass_source use MOM_barotropic, only : register_barotropic_restarts, set_dtbt, barotropic_CS +use MOM_barotropic, only : barotropic_end use MOM_boundary_update, only : update_OBC_data, update_OBC_CS -use MOM_continuity, only : continuity, continuity_init, continuity_CS +use MOM_continuity, only : continuity, continuity_CS +use MOM_continuity, only : continuity_init, continuity_end use MOM_continuity, only : continuity_stencil -use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type -use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init, hor_visc_CS +use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS +use MOM_hor_visc, only : hor_visc_init, hor_visc_end use MOM_interface_heights, only : find_eta use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds use MOM_open_boundary, only : open_boundary_zero_normal_flow use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp -use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS +use MOM_PressureForce, only : PressureForce, PressureForce_CS +use MOM_PressureForce, only : PressureForce_init, PressureForce_end use MOM_set_visc, only : set_viscous_ML, set_visc_CS use MOM_thickness_diffuse, only : thickness_diffuse_CS -use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_tidal_forcing, only : tidal_forcing_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant -use MOM_vert_friction, only : vertvisc_init, vertvisc_CS +use MOM_vert_friction, only : vertvisc_init, vertvisc_end, vertvisc_CS use MOM_vert_friction, only : updateCFLtruncationValue use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units @@ -160,9 +166,11 @@ module MOM_dynamics_split_RK2 integer :: id_PFu = -1, id_PFv = -1 integer :: id_CAu = -1, id_CAv = -1 ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 + integer :: id_h_PFu = -1, id_h_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_h_CAu = -1, id_h_CAv = -1 integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 integer :: id_intz_CAu_2d = -1, id_intz_CAv_2d = -1 @@ -170,6 +178,7 @@ module MOM_dynamics_split_RK2 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_h_u_BT_accel = -1, id_h_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 !>@} @@ -339,11 +348,17 @@ 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]. + ! Diagnostics for thickness x momentum budget terms + real, allocatable, dimension(:,:,:) :: & + h_PFu, h_PFv, & ! Pressure force accel. x thickness [H L T-2 ~> m2 s-2]. + h_CAu, h_CAv, & ! Coriolis force accel. x thickness [H L T-2 ~> m2 s-2]. + h_u_BT_accel, h_v_BT_accel ! barotropic correction accel. x thickness [H L T-2 ~> m2 s-2]. + ! Dignostics for layer-sum of thickness x momentum budget terms + real, dimension(SZIB_(G),SZJ_(G)) :: & + intz_PFu_2d, intz_CAu_2d, intz_u_BT_accel_2d ! [H L 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]. + intz_PFv_2d, intz_CAv_2d, intz_v_BT_accel_2d ! [H L T-2 ~> m2 s-2]. real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. @@ -940,6 +955,25 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s deallocate(hf_PFv_2d) endif + if (CS%id_h_PFu > 0) then + allocate(h_PFu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_PFu(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_PFu(I,j,k) = CS%PFu(I,j,k) * CS%ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_PFu, h_PFu, CS%diag) + deallocate(h_PFu) + endif + if (CS%id_h_PFv > 0) then + allocate(h_PFv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_PFv(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_PFv(i,J,k) = CS%PFv(i,J,k) * CS%ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_PFv, h_PFv, CS%diag) + deallocate(h_PFv) + endif + !if (CS%id_hf_CAu > 0) then ! allocate(hf_CAu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq @@ -988,6 +1022,25 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s deallocate(hf_CAv_2d) endif + if (CS%id_h_CAu > 0) then + allocate(h_CAu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_CAu(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_CAu(I,j,k) = CS%CAu(I,j,k) * CS%ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_CAu, h_CAu, CS%diag) + deallocate(h_CAu) + endif + if (CS%id_h_CAv > 0) then + allocate(h_CAv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_CAv(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_CAv(i,J,k) = CS%CAv(i,J,k) * CS%ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_CAv, h_CAv, CS%diag) + deallocate(h_CAv) + endif + !if (CS%id_hf_u_BT_accel > 0) then ! allocate(hf_u_BT_accel(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq @@ -1036,6 +1089,25 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s deallocate(hf_v_BT_accel_2d) endif + if (CS%id_h_u_BT_accel > 0) then + allocate(h_u_BT_accel(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_u_BT_accel(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_u_BT_accel(I,j,k) = CS%u_accel_bt(I,j,k) * CS%ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_u_BT_accel, h_u_BT_accel, CS%diag) + deallocate(h_u_BT_accel) + endif + if (CS%id_h_v_BT_accel > 0) then + allocate(h_v_BT_accel(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_v_BT_accel(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_v_BT_accel(i,J,k) = CS%v_accel_bt(i,J,k) * CS%ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_v_BT_accel, h_v_BT_accel, CS%diag) + deallocate(h_v_BT_accel) + endif + if (CS%debug) then call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -1185,7 +1257,6 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param ! a restart file to the internal representation in this run. real :: accel_rescale ! A rescaling factor for accelerations from the representation in ! a restart file to the internal representation in this run. - real :: H_convert type(group_pass_type) :: pass_av_h_uvh logical :: use_tides, debug_truncations @@ -1395,13 +1466,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call cpu_clock_end(id_clock_pass_init) flux_units = get_flux_units(GV) - H_convert = GV%H_to_m ; if (.not.GV%Boussinesq) H_convert = GV%H_to_kg_m2 CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & - 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & - 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & 'Zonal Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) @@ -1413,64 +1483,84 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) !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,JsdB,JedB,nz) + ! '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,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', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) !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,JsdB,JedB,nz) + ! '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,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', & - conversion=US%L_T2_to_m_s2) - if(CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) 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,JsdB,JedB,nz) + '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,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', & + CS%id_h_PFu = register_diag_field('ocean_model', 'h_PFu', diag%axesCuL, Time, & + 'Thickness Multiplied 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) + if(CS%id_h_PFu > 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', & + CS%id_h_PFv = register_diag_field('ocean_model', 'h_PFv', diag%axesCvL, Time, & + 'Thickness Multiplied 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) + if(CS%id_h_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,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', & - conversion=US%L_T2_to_m_s2) - if(CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) 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,JsdB,JedB,nz) + '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,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', & + CS%id_h_CAu = register_diag_field('ocean_model', 'h_CAu', diag%axesCuL, Time, & + 'Thickness Multiplied 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) + if(CS%id_h_CAu > 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', & + CS%id_h_CAv = register_diag_field('ocean_model', 'h_CAv', diag%axesCvL, Time, & + 'Thickness Multiplied 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) + if(CS%id_h_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,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) @@ -1483,34 +1573,44 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param 'Barotropic Anomaly Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) !CS%id_hf_u_BT_accel = register_diag_field('ocean_model', 'hf_u_BT_accel', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) !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,JsdB,JedB,nz) + ! '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,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', & - conversion=US%L_T2_to_m_s2) - if(CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) 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,JsdB,JedB,nz) + '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,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', & + CS%id_h_u_BT_accel = register_diag_field('ocean_model', 'h_u_BT_accel', diag%axesCuL, Time, & + 'Thickness Multiplied 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) + if(CS%id_h_u_BT_accel > 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', & + CS%id_h_v_BT_accel = register_diag_field('ocean_model', 'h_v_BT_accel', diag%axesCvL, Time, & + 'Thickness Multiplied 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) + if(CS%id_h_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hv,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) @@ -1530,6 +1630,28 @@ end subroutine initialize_dyn_split_RK2 subroutine end_dyn_split_RK2(CS) type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + call barotropic_end(CS%barotropic_CSp) + deallocate(CS%barotropic_CSp) + + call vertvisc_end(CS%vertvisc_CSp) + deallocate(CS%vertvisc_CSp) + + call hor_visc_end(CS%hor_visc_CSp) + + call PressureForce_end(CS%PressureForce_CSp) + deallocate(CS%PressureForce_CSp) + + if (associated(CS%tides_CSp)) then + call tidal_forcing_end(CS%tides_CSp) + deallocate(CS%tides_CSp) + endif + + call CoriolisAdv_end(CS%CoriolisAdv_Csp) + deallocate(CS%CoriolisAdv_CSp) + + call continuity_end(CS%continuity_CSp) + deallocate(CS%continuity_CSp) + DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 10b1f2e857..375f7e3ef1 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -612,7 +612,6 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS character(len=48) :: thickness_units, flux_units ! This include declares and sets the variable "version". # include "version_variable.h" - real :: H_convert logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke @@ -671,25 +670,20 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp flux_units = get_flux_units(GV) - H_convert = GV%H_to_m ; if (.not.GV%Boussinesq) H_convert = GV%H_to_kg_m2 CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & - 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & - 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & - 'Zonal Coriolis and Advective Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Zonal Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & - 'Meridional Coriolis and Advective Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Meridional Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_PFu = register_diag_field('ocean_model', 'PFu', diag%axesCuL, Time, & - 'Zonal Pressure Force Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Zonal Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & - 'Meridional Pressure Force Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) 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_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 8ca671d463..fea7f0d873 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -558,7 +558,6 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag character(len=48) :: thickness_units, flux_units ! This include declares and sets the variable "version". # include "version_variable.h" - real :: H_convert logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke @@ -632,13 +631,12 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag if (associated(OBC)) CS%OBC => OBC flux_units = get_flux_units(GV) - H_convert = GV%H_to_m ; if (.not.GV%Boussinesq) H_convert = GV%H_to_kg_m2 CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & - 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & - 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & 'Zonal Coriolis and Advective Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 60219c1c68..1ac5e39dd5 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -597,6 +597,13 @@ end subroutine allocate_metrics subroutine MOM_grid_end(G) type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type + deallocate(G%Block) + + if (G%bathymetry_at_vel) then + DEALLOC_(G%Dblock_u) ; DEALLOC_(G%Dopen_u) + DEALLOC_(G%Dblock_v) ; DEALLOC_(G%Dopen_v) + endif + DEALLOC_(G%dxT) ; DEALLOC_(G%dxCu) ; DEALLOC_(G%dxCv) ; DEALLOC_(G%dxBu) DEALLOC_(G%IdxT) ; DEALLOC_(G%IdxCu) ; DEALLOC_(G%IdxCv) ; DEALLOC_(G%IdxBu) @@ -622,11 +629,6 @@ subroutine MOM_grid_end(G) DEALLOC_(G%dF_dx) ; DEALLOC_(G%dF_dy) DEALLOC_(G%sin_rot) ; DEALLOC_(G%cos_rot) - if (G%bathymetry_at_vel) then - DEALLOC_(G%Dblock_u) ; DEALLOC_(G%Dopen_u) - DEALLOC_(G%Dblock_v) ; DEALLOC_(G%Dopen_v) - endif - deallocate(G%gridLonT) ; deallocate(G%gridLatT) deallocate(G%gridLonB) ; deallocate(G%gridLatB) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 98b5b10998..40777c8227 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -24,9 +24,10 @@ module MOM_isopycnal_slopes contains -!> Calculate isopycnal slopes, and optionally return N2 used in calculation. +!> Calculate isopycnal slopes, and optionally return other stratification dependent functions such as N^2 +!! and dz*S^2*g-prime used, or calculable from factors used, during the calculation. subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & - slope_x, slope_y, N2_u, N2_v, halo, OBC) !, eta_to_m) + slope_x, slope_y, N2_u, N2_v, dzu, dzv, dzSxN, dzSyN, halo, OBC) !, eta_to_m) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -45,6 +46,16 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at !! interfaces between v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzu !< Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzv !< Z-thickness at v-points [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzSxN !< Z-thickness times zonal slope contribution to + !! Eady growth rate at u-points. [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzSyN !< Z-thickness times meridional slope contrib. to + !! Eady growth rate at v-points. [Z T-1 ~> m s-1] integer, optional, intent(in) :: halo !< Halo width over which to compute type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. @@ -84,8 +95,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. 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 :: slope ! The slope of density surfaces, calculated in a way + ! that is always between -1 and 1. [Z L-1 ~> nondim] 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 @@ -147,6 +158,30 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & N2_v(i,J,nz+1) = 0. enddo ; enddo endif + if (present(dzu)) then + do j=js,je ; do I=is-1,ie + dzu(I,j,1) = 0. + dzu(I,j,nz+1) = 0. + enddo ; enddo + endif + if (present(dzv)) then + do J=js-1,je ; do i=is,ie + dzv(i,J,1) = 0. + dzv(i,J,nz+1) = 0. + enddo ; enddo + endif + if (present(dzSxN)) then + do j=js,je ; do I=is-1,ie + dzSxN(I,j,1) = 0. + dzSxN(I,j,nz+1) = 0. + enddo ; enddo + endif + if (present(dzSyN)) then + do J=js-1,je ; do i=is,ie + dzSyN(i,J,1) = 0. + dzSyN(i,J,nz+1) = 0. + enddo ; enddo + endif if (use_EOS) then if (present(halo)) then @@ -179,12 +214,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & - !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u,local_open_u_BC, & - !$OMP OBC) & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSxN,EOSdom_u,local_open_u_BC, & + !$OMP dzu,OBC) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,Slope,slope2_Ratio,l_seg) + !$OMP drdx,mag_grad2,slope,slope2_Ratio,l_seg) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -218,31 +253,34 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & endif + hg2A = h(i,j,k-1)*h(i+1,j,k-1) + h_neglect2 + hg2B = h(i,j,k)*h(i+1,j,k) + h_neglect2 + hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 + hg2R = h(i+1,j,k-1)*h(i+1,j,k) + h_neglect2 + haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect + haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect + haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect + if (GV%Boussinesq) then + dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z + else + dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect + dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect + endif + if (present(dzu)) dzu(I,j,K) = 0.5*( dzaL + dzaR ) + ! Use the harmonic mean thicknesses to weight the horizontal gradients. + ! These unnormalized weights have been rearranged to minimize divisions. + wtA = hg2A*haB ; wtB = hg2B*haA + wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) + + drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + ! The expression for drdz above is mathematically equivalent to: + ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & + ! ((hg2L/haL) + (hg2R/haR)) + ! This is the gradient of density along geopotentials. + 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] + if (use_EOS) then - hg2A = h(i,j,k-1)*h(i+1,j,k-1) + h_neglect2 - hg2B = h(i,j,k)*h(i+1,j,k) + h_neglect2 - hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 - hg2R = h(i+1,j,k-1)*h(i+1,j,k) + h_neglect2 - haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) - haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect - haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect - haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect - if (GV%Boussinesq) then - dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z - else - dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect - dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect - endif - ! Use the harmonic mean thicknesses to weight the horizontal gradients. - ! These unnormalized weights have been rearranged to minimize divisions. - wtA = hg2A*haB ; wtB = hg2B*haA - wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) - - drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) - ! The expression for drdz above is mathematically equivalent to: - ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & - ! ((hg2L/haL) + (hg2R/haR)) - ! This is the gradient of density along geopotentials. drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) @@ -250,21 +288,18 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! to be between -1 and 1. mag_grad2 = (Z_to_L*drdx)**2 + drdz**2 if (mag_grad2 > 0.0) then - slope_x(I,j,K) = drdx / sqrt(mag_grad2) + slope = drdx / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. - slope_x(I,j,K) = 0.0 + slope = 0.0 endif - - 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) = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu(I,j) + slope = (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) if (l_seg /= OBC_NONE) then if (OBC%segment(l_seg)%open) then - slope_x(I,j,K) = 0. + slope = 0. ! This and/or the masking code below is to make slopes match inside ! land mask. Might not be necessary except for DEBUG output. ! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then @@ -274,8 +309,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! endif endif endif - slope_x(I,j,K) = slope_x(I,j,k) * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) + slope = slope * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) endif + slope_x(I,j,K) = slope + if (present(dzSxN)) dzSxN(I,j,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 enddo ! I enddo ; enddo ! end of j-loop @@ -285,12 +324,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & - !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,EOSdom_v, & - !$OMP local_open_v_BC,OBC) & + !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,dzSyN,EOSdom_v, & + !$OMP dzv,local_open_v_BC,OBC) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,Slope,slope2_Ratio,l_seg) + !$OMP drdy,mag_grad2,slope,slope2_Ratio,l_seg) do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 @@ -321,31 +360,34 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & drho_dS_v(i) * (S(i,j+1,k)-S(i,j+1,k-1))) endif + hg2A = h(i,j,k-1)*h(i,j+1,k-1) + h_neglect2 + hg2B = h(i,j,k)*h(i,j+1,k) + h_neglect2 + hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 + hg2R = h(i,j+1,k-1)*h(i,j+1,k) + h_neglect2 + haA = 0.5*(h(i,j,k-1) + h(i,j+1,k-1)) + h_neglect + haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect + haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect + haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect + if (GV%Boussinesq) then + dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z + else + dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect + dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect + endif + if (present(dzv)) dzv(i,J,K) = 0.5*( dzaL + dzaR ) + ! Use the harmonic mean thicknesses to weight the horizontal gradients. + ! These unnormalized weights have been rearranged to minimize divisions. + wtA = hg2A*haB ; wtB = hg2B*haA + wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) + + drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + ! The expression for drdz above is mathematically equivalent to: + ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & + ! ((hg2L/haL) + (hg2R/haR)) + ! This is the gradient of density along geopotentials. + 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] + if (use_EOS) then - hg2A = h(i,j,k-1)*h(i,j+1,k-1) + h_neglect2 - hg2B = h(i,j,k)*h(i,j+1,k) + h_neglect2 - hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 - hg2R = h(i,j+1,k-1)*h(i,j+1,k) + h_neglect2 - haA = 0.5*(h(i,j,k-1) + h(i,j+1,k-1)) + h_neglect - haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect - haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect - haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect - if (GV%Boussinesq) then - dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z - else - dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect - dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect - endif - ! Use the harmonic mean thicknesses to weight the horizontal gradients. - ! These unnormalized weights have been rearranged to minimize divisions. - wtA = hg2A*haB ; wtB = hg2B*haA - wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) - - drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) - ! The expression for drdz above is mathematically equivalent to: - ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & - ! ((hg2L/haL) + (hg2R/haR)) - ! This is the gradient of density along geopotentials. drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) @@ -353,21 +395,20 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! to be between -1 and 1. mag_grad2 = (Z_to_L*drdy)**2 + drdz**2 if (mag_grad2 > 0.0) then - slope_y(i,J,K) = drdy / sqrt(mag_grad2) + slope = drdy / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. - slope_y(i,J,K) = 0.0 + slope = 0.0 endif - 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) = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv(i,J) + slope = (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) if (l_seg /= OBC_NONE) then if (OBC%segment(l_seg)%open) then - slope_y(i,J,K) = 0. + slope = 0. ! This and/or the masking code below is to make slopes match inside ! land mask. Might not be necessary except for DEBUG output. ! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then @@ -377,8 +418,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! endif endif endif - slope_y(i,J,K) = slope_y(i,J,k) * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) + slope = slope * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) endif + slope_y(i,J,K) = slope + if (present(dzSyN)) dzSyN(i,J,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 enddo ! i enddo ; enddo ! end of j-loop diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 0cb81e9978..bd76f5a9aa 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -177,7 +177,8 @@ module MOM_open_boundary !! segment [H L2 T-1 ~> m3 s-1]. real, pointer, dimension(:,:) :: normal_vel_bt=>NULL() !< The barotropic velocity normal to !! the OB segment [L T-1 ~> m s-1]. - real, pointer, dimension(:,:) :: eta=>NULL() !< The sea-surface elevation along the segment [m]. + real, pointer, dimension(:,:) :: eta=>NULL() !< The sea-surface elevation along the + !! segment [H ~> m or kg m-2]. real, pointer, dimension(:,:,:) :: grad_normal=>NULL() !< The gradient of the normal flow along the !! segment times the grid spacing [L T-1 ~> m s-1] real, pointer, dimension(:,:,:) :: grad_tan=>NULL() !< The gradient of the tangential flow along the @@ -4464,9 +4465,10 @@ subroutine OBC_registry_init(param_file, Reg) end subroutine OBC_registry_init !> Add file to OBC registry. -function register_file_OBC(param_file, CS, OBC_Reg) +function register_file_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(file_OBC_CS), pointer :: CS !< file control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. logical :: register_file_OBC character(len=32) :: casename = "OBC file" !< This case's name. diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 886ee77510..f966ab2ad2 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -204,7 +204,7 @@ module MOM_variables vhGM => NULL() !< Isopycnal height diffusion induced meridional volume fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] ! Each of the following fields is found at nz+1 interfaces. - real, pointer :: diapyc_vel(:,:,:) => NULL() !< The net diapycnal velocity [H s-1 ~> m s-1 or kg m-2 s-1] + real, pointer :: diapyc_vel(:,:,:) => NULL() !< The net diapycnal velocity [H T-1 ~> m s-1 or kg m-2 s-1] end type cont_diag_ptrs diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index bb5243892d..e6b01af33d 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -116,6 +116,7 @@ module MOM_diagnostics integer :: id_e = -1, id_e_D = -1 integer :: id_du_dt = -1, id_dv_dt = -1 ! integer :: id_hf_du_dt = -1, id_hf_dv_dt = -1 + integer :: id_h_du_dt = -1, id_h_dv_dt = -1 integer :: id_hf_du_dt_2d = -1, id_hf_dv_dt_2d = -1 integer :: id_col_ht = -1, id_dh_dt = -1 integer :: id_KE = -1, id_dKEdt = -1 @@ -196,7 +197,7 @@ module MOM_diagnostics contains !> Diagnostics not more naturally calculated elsewhere are computed here. subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & - dt, diag_pre_sync, G, GV, US, CS, eta_bt) + dt, diag_pre_sync, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -226,11 +227,6 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & type(diag_grid_storage), intent(in) :: diag_pre_sync !< Target grids from previous timestep type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a !! previous call to diagnostics_init. - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: eta_bt !< An optional barotropic - !! variable that gives the "correct" free surface height (Boussinesq) or total water column - !! mass per unit area (non-Boussinesq). This is used to dilate the layer thicknesses when - !! calculating interface heights [H ~> m or kg m-2]. ! Local variables real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: usq ! squared eastward velocity [L2 T-2 ~> m2 s-2] @@ -248,6 +244,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & real, allocatable, dimension(:,:) :: & hf_du_dt_2d, hf_dv_dt_2d ! z integeral of hf_du_dt, hf_dv_dt [L T-2 ~> m s-2]. + real, allocatable, dimension(:,:,:) :: h_du_dt ! h x dudt [H L T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_dv_dt ! h x dvdt [H L T-2 ~> m2 s-2] + ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa] @@ -325,6 +324,25 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & deallocate(hf_dv_dt_2d) endif + if (CS%id_h_du_dt > 0) then + allocate(h_du_dt(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_du_dt(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_du_dt(I,j,k) = CS%du_dt(I,j,k) * ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_du_dt, h_du_dt, CS%diag) + deallocate(h_du_dt) + endif + if (CS%id_h_dv_dt > 0) then + allocate(h_dv_dt(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_dv_dt(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_dv_dt(i,J,k) = CS%dv_dt(i,J,k) * ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_dv_dt, h_dv_dt, CS%diag) + deallocate(h_dv_dt) + endif + call diag_restore_grids(CS%diag) call calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS) @@ -367,7 +385,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (associated(CS%e)) then - call find_eta(h, tv, G, GV, US, CS%e, eta_bt) + call find_eta(h, tv, G, GV, US, CS%e) if (CS%id_e > 0) call post_data(CS%id_e, CS%e, CS%diag) endif @@ -377,7 +395,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%e_D(i,j,k) = CS%e(i,j,k) + G%bathyT(i,j) enddo ; enddo ; enddo else - call find_eta(h, tv, G, GV, US, CS%e_D, eta_bt) + call find_eta(h, tv, G, GV, US, CS%e_D) do k=1,nz+1 ; do j=js,je ; do i=is,ie CS%e_D(i,j,k) = CS%e_D(i,j,k) + G%bathyT(i,j) enddo ; enddo ; enddo @@ -1182,8 +1200,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_dia(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie - KE_h(i,j) = CS%KE(i,j,k) & - * (US%T_to_s * (CDp%diapyc_vel(i,j,k) - CDp%diapyc_vel(i,j,k+1))) + KE_h(i,j) = CS%KE(i,j,k) * (CDp%diapyc_vel(i,j,k) - CDp%diapyc_vel(i,j,k+1)) enddo ; enddo if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) @@ -1498,7 +1515,7 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy do k=1,nz ; do j=js,je ; do I=is-1,ie umo(I,j,k) = uhtr(I,j,k) * H_to_RZ_dt enddo ; enddo ; enddo - call post_data(IDs%id_umo, umo, diag, alt_h = diag_pre_dyn%h_state) + call post_data(IDs%id_umo, umo, diag, alt_h=diag_pre_dyn%h_state) endif if (IDs%id_vmo_2d > 0) then vmo2d(:,:) = 0.0 @@ -1512,20 +1529,20 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy do k=1,nz ; do J=js-1,je ; do i=is,ie vmo(i,J,k) = vhtr(i,J,k) * H_to_RZ_dt enddo ; enddo ; enddo - call post_data(IDs%id_vmo, vmo, diag, alt_h = diag_pre_dyn%h_state) + call post_data(IDs%id_vmo, vmo, diag, alt_h=diag_pre_dyn%h_state) endif - if (IDs%id_uhtr > 0) call post_data(IDs%id_uhtr, uhtr, diag, alt_h = diag_pre_dyn%h_state) - if (IDs%id_vhtr > 0) call post_data(IDs%id_vhtr, vhtr, diag, alt_h = diag_pre_dyn%h_state) + if (IDs%id_uhtr > 0) call post_data(IDs%id_uhtr, uhtr, diag, alt_h=diag_pre_dyn%h_state) + if (IDs%id_vhtr > 0) call post_data(IDs%id_vhtr, vhtr, diag, alt_h=diag_pre_dyn%h_state) if (IDs%id_dynamics_h > 0) call post_data(IDs%id_dynamics_h, diag_pre_dyn%h_state, diag, & - alt_h = diag_pre_dyn%h_state) + alt_h=diag_pre_dyn%h_state) ! Post the change in thicknesses if (IDs%id_dynamics_h_tendency > 0) then h_tend(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie h_tend(i,j,k) = (h(i,j,k) - diag_pre_dyn%h_state(i,j,k))*Idt enddo ; enddo ; enddo - call post_data(IDs%id_dynamics_h_tendency, h_tend, diag, alt_h = diag_pre_dyn%h_state) + call post_data(IDs%id_dynamics_h_tendency, h_tend, diag, alt_h=diag_pre_dyn%h_state) endif call post_tracer_transport_diagnostics(G, GV, Reg, diag_pre_dyn%h_state, diag) @@ -1695,8 +1712,8 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%id_vsq = register_diag_field('ocean_model', 'vsq', diag%axesCvL, Time, & 'Meridional velocity squared', 'm2 s-2', conversion=US%L_T_to_m_s**2) CS%id_uv = register_diag_field('ocean_model', 'uv', diag%axesTL, Time, & - 'Product between zonal and meridional velocities at h-points', 'm2 s-2', & - conversion=US%L_T_to_m_s**2) + 'Product between zonal and meridional velocities at h-points', & + 'm2 s-2', conversion=US%L_T_to_m_s**2) CS%id_h = register_diag_field('ocean_model', 'h', diag%axesTL, Time, & 'Layer Thickness', thickness_units, v_extensive=.true., conversion=convert_H) @@ -1747,8 +1764,8 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag endif !CS%id_hf_du_dt = register_diag_field('ocean_model', 'hf_dudt', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Zonal Acceleration', 'm s-2', v_extensive=.true., & - ! conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2, & + ! v_extensive=.true.) !if (CS%id_hf_du_dt > 0) then ! call safe_alloc_ptr(CS%hf_du_dt,IsdB,IedB,jsd,jed,nz) ! if (.not.associated(CS%du_dt)) then @@ -1759,8 +1776,8 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag !endif !CS%id_hf_dv_dt = register_diag_field('ocean_model', 'hf_dvdt', diag%axesCvL, Time, & - ! 'Fractional Thickness-weighted Meridional Acceleration', 'm s-2', v_extensive=.true., & - ! conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2, & + ! v_extensive=.true.) !if (CS%id_hf_dv_dt > 0) then ! call safe_alloc_ptr(CS%hf_dv_dt,isd,ied,JsdB,JedB,nz) ! if (.not.associated(CS%dv_dt)) then @@ -1790,6 +1807,26 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) endif + CS%id_h_du_dt = register_diag_field('ocean_model', 'h_du_dt', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration', 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_du_dt > 0) then + if (.not.associated(CS%du_dt)) then + call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) + call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_h_dv_dt = register_diag_field('ocean_model', 'h_dv_dt', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration', 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_dv_dt > 0) then + if (.not.associated(CS%dv_dt)) then + 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_hv,isd,ied,JsdB,JedB,nz) + endif + ! layer thickness variables !if (GV%nk_rho_varies > 0) then CS%id_h_Rlay = register_diag_field('ocean_model', 'h_rho', diag%axesTL, Time, & @@ -1893,7 +1930,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call wave_speed_init(CS%wave_speed_CSp, remap_answers_2018=remap_answers_2018, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & wave_speed_tol=wave_speed_tol) - call wave_speed_init(CS%wave_speed_CSp, remap_answers_2018=remap_answers_2018) +!### call wave_speed_init(CS%wave_speed_CSp, remap_answers_2018=remap_answers_2018) call safe_alloc_ptr(CS%cg1,isd,ied,jsd,jed) if (CS%id_Rd1>0) call safe_alloc_ptr(CS%Rd1,isd,ied,jsd,jed) if (CS%id_Rd_ebt>0) call safe_alloc_ptr(CS%Rd1,isd,ied,jsd,jed) @@ -2000,8 +2037,8 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) endif IDs%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & - 'Salt sink in ocean due to ice flux', & - 'psu m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + 'Salt source in ocean required to supply excessive ice salt fluxes', & + 'ppt kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) IDs%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & 'Heat flux into ocean from mass flux into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) @@ -2021,22 +2058,22 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output real :: H_convert - character(len=48) :: thickness_units + character(len=48) :: thickness_units, accum_flux_units thickness_units = get_thickness_units(GV) if (GV%Boussinesq) then - H_convert = GV%H_to_m + H_convert = GV%H_to_m ; accum_flux_units = "m3" else - H_convert = GV%H_to_kg_m2 + H_convert = GV%H_to_kg_m2 ; accum_flux_units = "kg" endif ! Diagnostics related to tracer and mass transport IDs%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & - 'Accumulated zonal thickness fluxes to advect tracers', 'kg', & - y_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) + 'Accumulated zonal thickness fluxes to advect tracers', & + accum_flux_units, y_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) IDs%id_vhtr = register_diag_field('ocean_model', 'vhtr', diag%axesCvL, Time, & - 'Accumulated meridional thickness fluxes to advect tracers', 'kg', & - x_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) + 'Accumulated meridional thickness fluxes to advect tracers', & + accum_flux_units, x_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) IDs%id_umo = register_diag_field('ocean_model', 'umo', & diag%axesCuL, Time, 'Ocean Mass X Transport', & 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & @@ -2054,8 +2091,8 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & standard_name='ocean_mass_y_transport_vertical_sum', x_cell_method='sum') IDs%id_dynamics_h = register_diag_field('ocean_model','dynamics_h', & - diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & - 'm s-1', v_extensive=.true., conversion=GV%H_to_m) + diag%axesTl, Time, 'Layer thicknesses prior to horizontal dynamics', & + 'm', v_extensive=.true., conversion=GV%H_to_m) IDs%id_dynamics_h_tendency = register_diag_field('ocean_model','dynamics_h_tendency', & diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & 'm s-1', v_extensive=.true., conversion=GV%H_to_m*US%s_to_T) @@ -2298,11 +2335,13 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) end subroutine set_dependent_diagnostics !> Deallocate memory associated with the diagnostics module -subroutine MOM_diagnostics_end(CS, ADp) - type(diagnostics_CS), pointer :: CS !< Control structure returned by a - !! previous call to diagnostics_init. - type(accel_diag_ptrs), intent(inout) :: ADp !< structure with pointers to - !! accelerations in momentum equation. +subroutine MOM_diagnostics_end(CS, ADp, CDp) + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a + !! previous call to diagnostics_init. + type(accel_diag_ptrs), intent(inout) :: ADp !< structure with pointers to + !! accelerations in momentum equation. + type(cont_diag_ptrs), intent(inout) :: CDp !< Structure pointing to terms in continuity + !! equation. integer :: m if (associated(CS%e)) deallocate(CS%e) @@ -2337,10 +2376,12 @@ subroutine MOM_diagnostics_end(CS, ADp) if (associated(ADp%diag_hfrac_u)) deallocate(ADp%diag_hfrac_u) if (associated(ADp%diag_hfrac_v)) deallocate(ADp%diag_hfrac_v) - do m=1,CS%num_time_deriv ; deallocate(CS%prev_val(m)%p) ; enddo - - deallocate(CS) + ! NOTE: [uv]hGM may be allocated either here or the thickness diffuse module + if (associated(CDp%uhGM)) deallocate(CDp%uhGM) + if (associated(CDp%vhGM)) deallocate(CDp%vhGM) + if (associated(CDp%diapyc_vel)) deallocate(CDp%diapyc_vel) + do m=1,CS%num_time_deriv ; deallocate(CS%prev_val(m)%p) ; enddo end subroutine MOM_diagnostics_end end module MOM_diagnostics diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index b2e0275ea8..72523edfd3 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -4,37 +4,37 @@ module MOM_sum_output ! This file is part of MOM6. See LICENSE.md for the license. use iso_fortran_env, only : int64 -use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs, field_chksum -use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP -use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs +use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs, field_chksum +use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP +use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta -use MOM_io, only : create_file, file_type, fieldtype, flush_file, reopen_file -use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, get_filename_appendix -use MOM_io, only : field_size, read_variable, read_attribute, open_ASCII_file, stdout -use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE +use MOM_io, only : create_file, file_type, fieldtype, flush_file, reopen_file, close_file +use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, MOM_write_field +use MOM_io, only : field_size, read_variable, read_attribute, open_ASCII_file, stdout +use MOM_io, only : axis_info, set_axis_info, delete_axis_info, get_filename_appendix +use MOM_io, only : attribute_info, set_attribute_info, delete_attribute_info +use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S -use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) -use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) -use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) -use MOM_time_manager, only : get_calendar_type, time_type_to_real, NO_CALENDAR +use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) +use MOM_time_manager, only : get_calendar_type, time_type_to_real, NO_CALENDAR use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_stocks -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type - -use netcdf, only : NF90_create, NF90_def_dim, NF90_def_var, NF90_enddef, NF90_put_att, NF90_put_var -use netcdf, only : NF90_close, NF90_strerror, NF90_DOUBLE, NF90_NOERR, NF90_GLOBAL +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private #include -public write_energy, accumulate_net_input, MOM_sum_output_init +public write_energy, accumulate_net_input +public MOM_sum_output_init, MOM_sum_output_end ! 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 @@ -1265,8 +1265,15 @@ subroutine write_depth_list(G, US, DL, filename) character(len=*), intent(in) :: filename !< The path to the depth list file to write. ! Local variables - real, allocatable :: tmp(:) - integer :: ncid, dimid(1), Did, Aid, Vid, status, k + type(vardesc), dimension(:), allocatable :: & + vars ! Types that described the staggering and metadata for the fields + type(fieldtype), dimension(:), allocatable :: & + fields ! Types with metadata about the variables that will be written + type(axis_info), dimension(:), allocatable :: & + extra_axes ! Descriptors for extra axes that might be used + type(attribute_info), dimension(:), allocatable :: & + global_atts ! Global attributes and their values + type(file_type) :: IO_handle ! The I/O handle of the fileset character(len=16) :: depth_chksum, area_chksum ! All ranks are required to compute the global checksum @@ -1274,79 +1281,28 @@ subroutine write_depth_list(G, US, DL, filename) if (.not.is_root_pe()) return - allocate(tmp(DL%listsize)) ; tmp(:) = 0.0 - - status = NF90_CREATE(filename, 0, ncid) - if (status /= NF90_NOERR) then - call MOM_error(WARNING, trim(filename)//trim(NF90_STRERROR(status))) - return - endif - - status = NF90_DEF_DIM(ncid, "list", DL%listsize, dimid(1)) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//trim(NF90_STRERROR(status))) - - status = NF90_DEF_VAR(ncid, "depth", NF90_DOUBLE, dimid, Did) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" depth "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Did, "long_name", "Sorted depth") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" depth "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Did, "units", "m") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" depth "//trim(NF90_STRERROR(status))) - - status = NF90_DEF_VAR(ncid, "area", NF90_DOUBLE, dimid, Aid) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" area "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Aid, "long_name", "Open area at depth") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" area "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Aid, "units", "m2") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" area "//trim(NF90_STRERROR(status))) - - status = NF90_DEF_VAR(ncid, "vol_below", NF90_DOUBLE, dimid, Vid) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Vid, "long_name", "Open volume below depth") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Vid, "units", "m3") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) - - ! Dependency checksums - status = NF90_PUT_ATT(ncid, NF90_GLOBAL, depth_chksum_attr, depth_chksum) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" "//depth_chksum_attr//" "//trim(NF90_STRERROR(status))) - - status = NF90_PUT_ATT(ncid, NF90_GLOBAL, area_chksum_attr, area_chksum) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" "//area_chksum_attr//" "//trim(NF90_STRERROR(status))) - - status = NF90_ENDDEF(ncid) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//trim(NF90_STRERROR(status))) - - do k=1,DL%listsize ; tmp(k) = US%Z_to_m*DL%depth(k) ; enddo - status = NF90_PUT_VAR(ncid, Did, tmp) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" depth "//trim(NF90_STRERROR(status))) - - do k=1,DL%listsize ; tmp(k) = US%L_to_m**2*DL%area(k) ; enddo - status = NF90_PUT_VAR(ncid, Aid, tmp) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" area "//trim(NF90_STRERROR(status))) - - do k=1,DL%listsize ; tmp(k) = US%Z_to_m*US%L_to_m**2*DL%vol_below(k) ; enddo - status = NF90_PUT_VAR(ncid, Vid, tmp) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) - - status = NF90_CLOSE(ncid) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//trim(NF90_STRERROR(status))) + allocate(vars(3)) + allocate(fields(3)) + allocate(extra_axes(1)) + allocate(global_atts(2)) + + call set_axis_info(extra_axes(1), "list", ax_size=DL%listsize) + vars(1) = var_desc("depth", "m", "Sorted depth", '1', dim_names=(/"list"/), fixed=.true.) + vars(2) = var_desc("area", "m2", "Open area at depth", '1', dim_names=(/"list"/), fixed=.true.) + vars(3) = var_desc("vol_below", "m3", "Open volume below depth", '1', dim_names=(/"list"/), fixed=.true.) + call set_attribute_info(global_atts(1), depth_chksum_attr, depth_chksum) + call set_attribute_info(global_atts(2), area_chksum_attr, area_chksum) + + call create_file(IO_handle, filename, vars, 3, fields, SINGLE_FILE, extra_axes=extra_axes, & + global_atts=global_atts) + call MOM_write_field(IO_handle, fields(1), DL%depth, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(2), DL%area, scale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(3), DL%vol_below, scale=US%Z_to_m*US%L_to_m**2) + + call delete_axis_info(extra_axes) + call delete_attribute_info(global_atts) + deallocate(vars, extra_axes, fields, global_atts) + call close_file(IO_handle) end subroutine write_depth_list diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index a3e60cf584..678c48bd03 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -21,7 +21,7 @@ module MOM_wave_structure use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use regrid_edge_values, only : solve_diag_dominant_tridiag +use regrid_solvers, only : solve_diag_dominant_tridiag implicit none ; private 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_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index b4cce081a0..e068d26f5d 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1051,6 +1051,7 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num else axes%v_cell_method = '' endif + if (present(nz)) axes%nz = nz if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number if (present(is_h_point)) axes%is_h_point = is_h_point @@ -1971,6 +1972,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time type(diag_ctrl), pointer :: diag_cs => NULL() type(axes_grp), pointer :: remap_axes => null() type(axes_grp), pointer :: axes => null() + type(axes_grp), pointer :: axes_d2 => null() integer :: dm_id, i, dl character(len=256) :: msg, cm_string character(len=256) :: new_module_name @@ -1978,18 +1980,15 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time integer :: num_modnm, num_varnm logical :: active - axes => axes_in - MOM_missing_value = axes%diag_cs%missing_value - if (present(missing_value)) MOM_missing_value = missing_value - - diag_cs => axes%diag_cs - dm_id = -1 + diag_cs => axes_in%diag_cs + ! Check if the axes match a standard grid axis. + ! If not, allocate the new axis and copy the contents. if (axes_in%id == diag_cs%axesTL%id) then axes => diag_cs%axesTL elseif (axes_in%id == diag_cs%axesBL%id) then axes => diag_cs%axesBL - elseif (axes_in%id == diag_cs%axesCuL%id ) then + elseif (axes_in%id == diag_cs%axesCuL%id) then axes => diag_cs%axesCuL elseif (axes_in%id == diag_cs%axesCvL%id) then axes => diag_cs%axesCvL @@ -1997,12 +1996,21 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time axes => diag_cs%axesTi elseif (axes_in%id == diag_cs%axesBi%id) then axes => diag_cs%axesBi - elseif (axes_in%id == diag_cs%axesCui%id ) then + elseif (axes_in%id == diag_cs%axesCui%id) then axes => diag_cs%axesCui elseif (axes_in%id == diag_cs%axesCvi%id) then axes => diag_cs%axesCvi + else + allocate(axes) + axes = axes_in endif + MOM_missing_value = axes%diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + diag_cs => axes%diag_cs + dm_id = -1 + module_list = "{"//trim(module_name) num_modnm = 1 @@ -2090,31 +2098,31 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time new_module_name = trim(module_name)//'_d2' if (axes_in%rank == 3 .or. axes_in%rank == 2 ) then - axes => null() + axes_d2 => null() if (axes_in%id == diag_cs%axesTL%id) then - axes => diag_cs%dsamp(dl)%axesTL + axes_d2 => diag_cs%dsamp(dl)%axesTL elseif (axes_in%id == diag_cs%axesBL%id) then - axes => diag_cs%dsamp(dl)%axesBL + axes_d2 => diag_cs%dsamp(dl)%axesBL elseif (axes_in%id == diag_cs%axesCuL%id ) then - axes => diag_cs%dsamp(dl)%axesCuL + axes_d2 => diag_cs%dsamp(dl)%axesCuL elseif (axes_in%id == diag_cs%axesCvL%id) then - axes => diag_cs%dsamp(dl)%axesCvL + axes_d2 => diag_cs%dsamp(dl)%axesCvL elseif (axes_in%id == diag_cs%axesTi%id) then - axes => diag_cs%dsamp(dl)%axesTi + axes_d2 => diag_cs%dsamp(dl)%axesTi elseif (axes_in%id == diag_cs%axesBi%id) then - axes => diag_cs%dsamp(dl)%axesBi + axes_d2 => diag_cs%dsamp(dl)%axesBi elseif (axes_in%id == diag_cs%axesCui%id ) then - axes => diag_cs%dsamp(dl)%axesCui + axes_d2 => diag_cs%dsamp(dl)%axesCui elseif (axes_in%id == diag_cs%axesCvi%id) then - axes => diag_cs%dsamp(dl)%axesCvi + axes_d2 => diag_cs%dsamp(dl)%axesCvi elseif (axes_in%id == diag_cs%axesT1%id) then - axes => diag_cs%dsamp(dl)%axesT1 + axes_d2 => diag_cs%dsamp(dl)%axesT1 elseif (axes_in%id == diag_cs%axesB1%id) then - axes => diag_cs%dsamp(dl)%axesB1 + axes_d2 => diag_cs%dsamp(dl)%axesB1 elseif (axes_in%id == diag_cs%axesCu1%id ) then - axes => diag_cs%dsamp(dl)%axesCu1 + axes_d2 => diag_cs%dsamp(dl)%axesCu1 elseif (axes_in%id == diag_cs%axesCv1%id) then - axes => diag_cs%dsamp(dl)%axesCv1 + axes_d2 => diag_cs%dsamp(dl)%axesCv1 else !Niki: Should we worry about these, e.g., diag_to_Z_CS? call MOM_error(WARNING,"register_diag_field: Could not find a proper axes for " & @@ -2122,8 +2130,8 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time endif endif ! Register the native diagnostic - if (associated(axes)) then - active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes, & + if (associated(axes_d2)) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes_d2, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2196,7 +2204,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time v_extensive=v_extensive) module_list = trim(module_list)//"}" if (num_modnm <= 1) module_list = module_name - if (num_varnm <= 1) var_list = "" + if (num_varnm <= 1) var_list = '' call log_available_diag(dm_id>0, module_list, field_name, cm_string, msg, diag_CS, & long_name, units, standard_name, variants=var_list) @@ -2216,7 +2224,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes + type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes !! for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. @@ -3375,13 +3383,22 @@ subroutine diag_mediator_close_registration(diag_CS) end subroutine diag_mediator_close_registration +subroutine axes_grp_end(axes) + type(axes_grp), intent(inout) :: axes !< Axes group to be destroyed + + deallocate(axes%handles) + if (associated(axes%mask2d)) deallocate(axes%mask2d) + if (associated(axes%mask3d)) deallocate(axes%mask3d) +end subroutine axes_grp_end + subroutine diag_mediator_end(time, diag_CS, end_diag_manager) type(time_type), intent(in) :: time !< The current model time type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: end_diag_manager !< If true, call diag_manager_end() ! Local variables - integer :: i + type(diag_type), pointer :: diag, next_diag + integer :: i, dl if (diag_CS%available_diag_doc_unit > -1) then close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -3 @@ -3390,6 +3407,17 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) close(diag_CS%chksum_iounit) ; diag_CS%chksum_iounit = -3 endif + do i=1, diag_cs%next_free_diag_id - 1 + if (associated(diag_cs%diags(i)%next)) then + next_diag => diag_cs%diags(i)%next + do while (associated(next_diag)) + diag => next_diag + next_diag => diag%next + deallocate(diag) + enddo + endif + enddo + deallocate(diag_cs%diags) do i=1, diag_cs%num_diag_coords @@ -3405,21 +3433,77 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) deallocate(diag_cs%mask3dBi) deallocate(diag_cs%mask3dCui) deallocate(diag_cs%mask3dCvi) - do i=2,MAX_DSAMP_LEV - deallocate(diag_cs%dsamp(i)%mask2dT) - deallocate(diag_cs%dsamp(i)%mask2dBu) - deallocate(diag_cs%dsamp(i)%mask2dCu) - deallocate(diag_cs%dsamp(i)%mask2dCv) - deallocate(diag_cs%dsamp(i)%mask3dTL) - deallocate(diag_cs%dsamp(i)%mask3dBL) - deallocate(diag_cs%dsamp(i)%mask3dCuL) - deallocate(diag_cs%dsamp(i)%mask3dCvL) - deallocate(diag_cs%dsamp(i)%mask3dTi) - deallocate(diag_cs%dsamp(i)%mask3dBi) - deallocate(diag_cs%dsamp(i)%mask3dCui) - deallocate(diag_cs%dsamp(i)%mask3dCvi) + do dl=2,MAX_DSAMP_LEV + deallocate(diag_cs%dsamp(dl)%mask2dT) + deallocate(diag_cs%dsamp(dl)%mask2dBu) + deallocate(diag_cs%dsamp(dl)%mask2dCu) + deallocate(diag_cs%dsamp(dl)%mask2dCv) + deallocate(diag_cs%dsamp(dl)%mask3dTL) + deallocate(diag_cs%dsamp(dl)%mask3dBL) + deallocate(diag_cs%dsamp(dl)%mask3dCuL) + deallocate(diag_cs%dsamp(dl)%mask3dCvL) + deallocate(diag_cs%dsamp(dl)%mask3dTi) + deallocate(diag_cs%dsamp(dl)%mask3dBi) + deallocate(diag_cs%dsamp(dl)%mask3dCui) + deallocate(diag_cs%dsamp(dl)%mask3dCvi) + + do i=1,diag_cs%num_diag_coords + deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) + enddo enddo + ! axes_grp masks may point to diag_cs masks, so do these after mask dealloc + do i=1, diag_cs%num_diag_coords + call axes_grp_end(diag_cs%remap_axesZL(i)) + call axes_grp_end(diag_cs%remap_axesZi(i)) + call axes_grp_end(diag_cs%remap_axesTL(i)) + call axes_grp_end(diag_cs%remap_axesTi(i)) + call axes_grp_end(diag_cs%remap_axesBL(i)) + call axes_grp_end(diag_cs%remap_axesBi(i)) + call axes_grp_end(diag_cs%remap_axesCuL(i)) + call axes_grp_end(diag_cs%remap_axesCui(i)) + call axes_grp_end(diag_cs%remap_axesCvL(i)) + call axes_grp_end(diag_cs%remap_axesCvi(i)) + enddo + + deallocate(diag_cs%remap_axesZL) + deallocate(diag_cs%remap_axesZi) + deallocate(diag_cs%remap_axesTL) + deallocate(diag_cs%remap_axesTi) + deallocate(diag_cs%remap_axesBL) + deallocate(diag_cs%remap_axesBi) + deallocate(diag_cs%remap_axesCuL) + deallocate(diag_cs%remap_axesCui) + deallocate(diag_cs%remap_axesCvL) + deallocate(diag_cs%remap_axesCvi) + + do dl=2,MAX_DSAMP_LEV + if (allocated(diag_cs%dsamp(dl)%remap_axesTL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTL) + if (allocated(diag_cs%dsamp(dl)%remap_axesTi)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTi) + if (allocated(diag_cs%dsamp(dl)%remap_axesBL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBL) + if (allocated(diag_cs%dsamp(dl)%remap_axesBi)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBi) + if (allocated(diag_cs%dsamp(dl)%remap_axesCuL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCuL) + if (allocated(diag_cs%dsamp(dl)%remap_axesCui)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCui) + if (allocated(diag_cs%dsamp(dl)%remap_axesCvL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvL) + if (allocated(diag_cs%dsamp(dl)%remap_axesCvi)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvi) + enddo + + #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) deallocate(diag_cs%h_old) #endif @@ -4146,42 +4230,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_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index d8a098d12c..d3eb21dcbe 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -72,6 +72,7 @@ module MOM_diag_remap use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : remapping_core_h use MOM_regridding, only : regridding_CS, initialize_regridding +use MOM_regridding, only : end_regridding use MOM_regridding, only : set_regrid_params, get_regrid_size use MOM_regridding, only : getCoordinateInterfaces use MOM_regridding, only : get_zlike_CS, get_sigma_CS, get_rho_CS @@ -148,6 +149,7 @@ subroutine diag_remap_end(remap_cs) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure if (allocated(remap_cs%h)) deallocate(remap_cs%h) + remap_cs%configured = .false. remap_cs%initialized = .false. remap_cs%used = .false. @@ -165,6 +167,7 @@ subroutine diag_remap_diag_registration_closed(remap_cs) if (.not. remap_cs%used) then call diag_remap_end(remap_cs) + call end_regridding(remap_cs%regrid_cs) endif end subroutine diag_remap_diag_registration_closed 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_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index 141340047d..2a9a381caa 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -5,7 +5,7 @@ module MOM_dyn_horgrid ! This file is part of MOM6. See LICENSE.md for the license. use MOM_hor_index, only : hor_index_type -use MOM_domains, only : MOM_domain_type +use MOM_domains, only : MOM_domain_type, deallocate_MOM_domain use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_unit_scaling, only : unit_scale_type @@ -413,8 +413,10 @@ subroutine destroy_dyn_horgrid(G) deallocate(G%gridLonT) ; deallocate(G%gridLatT) deallocate(G%gridLonB) ; deallocate(G%gridLatB) - deallocate(G%Domain%mpp_domain) - deallocate(G%Domain) + ! CS%debug is required to validate Domain_aux, so use allocation test + if (associated(G%Domain_aux)) call deallocate_MOM_domain(G%Domain_aux) + + call deallocate_MOM_domain(G%Domain) deallocate(G) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 3e7a2f9e84..07e9138594 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -196,6 +196,8 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) CS%iounit(i) = iounit CS%filename(i) = filename CS%NetCDF_file(i) = Netcdf_file + + if (associated(CS%blockName)) deallocate(CS%blockName) allocate(block) ; block%name = '' ; CS%blockName => block call MOM_mesg("open_param_file: "// trim(filename)// & @@ -332,6 +334,7 @@ subroutine close_param_file(CS, quiet_close, component) deallocate (CS%param_data(i)%line) deallocate (CS%param_data(i)%line_used) enddo + deallocate(CS%blockName) if (is_root_pe() .and. (num_unused>0) .and. CS%unused_params_fatal) & call MOM_error(FATAL, "Run stopped because of unused parameter lines.") diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 8d02dfdf3f..d1a4b7f45d 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 @@ -259,7 +259,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, character(len=*), intent(in) :: filename !< Path to file containing tracer to be !! interpolated. - character(len=*), intent(in) :: varnam !< Name of tracer in filee. + character(len=*), intent(in) :: varnam !< Name of tracer in file. real, intent(in) :: conversion !< Conversion factor for tracer. integer, intent(in) :: recnum !< Record number of tracer to be read. type(ocean_grid_type), intent(inout) :: G !< Grid object @@ -348,9 +348,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_VARIABLE(ncid, varid, ndims=ndims, dimids=dims) - if (rcode /= 0) call MOM_error(FATAL,'error inquiring dimensions hinterp_extrap') - if (ndims < 3) call MOM_error(FATAL,"Variable "//trim(varnam)//" in file "// & - trim(filename)//" has too few dimensions.") + if (rcode /= 0) call MOM_error(FATAL, "Error inquiring about the dimensions of "//trim(varnam)//& + " in file "//trim(filename)//" in hinterp_extrap") + if (ndims < 3) call MOM_error(FATAL,"Variable "//trim(varnam)//" in file "//trim(filename)// & + " has too few dimensions to be read as a 3-d array.") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & @@ -373,8 +374,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, missing_value=0.0 rcode = NF90_GET_ATT(ncid, varid, "_FillValue", missing_value) - if (rcode /= 0) call MOM_error(FATAL,"error finding missing value for "//& - trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") + if (rcode /= 0) call MOM_error(FATAL,"error finding missing value for "//trim(varnam)//& + " in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_GET_ATT(ncid, varid, "add_offset", add_offset) if (rcode /= 0) add_offset = 0.0 @@ -465,7 +466,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = k count(1) = ie-is+1 ; count(2) = je-js+1; count(3) = 1 rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& + if (rcode /= 0) call MOM_error(FATAL,"horiz_interp_and_extrap_tracer_record: "//& "error reading level "//trim(laynum)//" of variable "//& trim(varnam)//" in file "// trim(filename)) @@ -484,7 +485,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (is_root_pe()) then start = 1 ; start(3) = k ; count(:) = 1 ; count(1) = id ; count(2) = jd rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& + if (rcode /= 0) call MOM_error(FATAL,"horiz_interp_and_extrap_tracer_record: "//& "error reading level "//trim(laynum)//" of variable "//& trim(varnam)//" in file "// trim(filename)) 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..f8cfb09382 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -19,6 +19,7 @@ module MOM_io use MOM_io_infra, only : get_file_times, axistype, get_axis_data, get_filename_suffix use MOM_io_infra, only : write_field, write_metadata, write_version use MOM_io_infra, only : MOM_namelist_file, check_namelist_error, io_infra_init, io_infra_end +use MOM_io_infra, only : stdout_if_root use MOM_io_infra, only : APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE use MOM_io_infra, only : READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_io_infra, only : CENTER, CORNER, NORTH_FACE, EAST_FACE @@ -35,7 +36,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 +48,11 @@ 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 +public :: stdout_if_root +! 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 +100,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 +134,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 +154,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 +227,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 +277,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 +311,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 +345,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 +441,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 +456,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 +471,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 +491,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 +513,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 +533,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,"." @@ -533,7 +649,7 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, al do n=2,nval ; sizes(n-1) = size_msg(n) ; enddo deallocate(size_msg) - if (present(dim_names)) then + if (present(dim_names) .and. (ndims > 0)) then nval = min(ndims, size(dim_names)) call broadcast(dim_names(1:nval), len(dim_names(1)), blocking=.true.) endif @@ -541,7 +657,8 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, al end subroutine get_var_sizes -!> read_var_sizes returns the number and size of dimensions associate with a variable in a file. +!> read_var_sizes returns the number and size of dimensions associated with a variable in a file. +!! If the variable is not in the file the returned sizes are all 0 and ndims is -1. !! Every processor for which this is called does the reading. subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, dim_names, ncid_in) character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages @@ -561,7 +678,7 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d character(len=256) :: hdr, dimname integer, allocatable :: dimids(:) integer :: varid, ncid, n, status - logical :: success + logical :: success, found hdr = "get_var_size: " ; if (present(caller)) hdr = trim(hdr)//": " sizes(:) = 0 ; ndims = -1 @@ -573,8 +690,8 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d endif ! Get the dimension sizes of the variable varname. - call get_varid(varname, ncid, filename, varid, match_case=match_case) - if (varid < 0) return + call get_varid(varname, ncid, filename, varid, match_case=match_case, found=found) + if (.not.found) return status = NF90_inquire_variable(ncid, varid, ndims=ndims) if (status /= NF90_NOERR) then @@ -597,7 +714,7 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d if (status /= NF90_NOERR) call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& " Getting dimension length for "//trim(varname)//" in "//trim(filename)) if (present(dim_names)) then - if (n <= size(dim_names)) dim_names = trim(dimname) + if (n <= size(dim_names)) dim_names(n) = trim(dimname) endif enddo deallocate(dimids) @@ -792,18 +909,20 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re endif if ((varid > 0) .or. (varid == NF90_GLOBAL)) then ! The named variable does exist, and found would be true. rc = NF90_inquire_attribute(ncid, varid, attname, xtype=att_type, len=att_len) - if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & - call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Error getting info for "//trim(att_str)) - if (att_type /= NF90_CHAR) & - call MOM_error(FATAL, trim(hdr)//": Attribute data type is not a char for "//trim(att_str)) -! if (att_len > len(att_val)) & -! call MOM_error(FATAL, trim(hdr)//": Insufficiently long string passed in to read "//trim(att_str)) - allocate(character(att_len) :: att_val) - - if (rc == NF90_NOERR) then - rc = NF90_get_att(ncid, varid, attname, att_val) + if ((.not. present(found)) .or. (rc /= NF90_ENOTATT)) then if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & - call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading "//trim(att_str)) + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Error getting info for "//trim(att_str)) + if (att_type /= NF90_CHAR) & + call MOM_error(FATAL, trim(hdr)//": Attribute data type is not a char for "//trim(att_str)) + ! if (att_len > len(att_val)) & + ! call MOM_error(FATAL, trim(hdr)//": Insufficiently long string passed in to read "//trim(att_str)) + allocate(character(att_len) :: att_val) + + if (rc == NF90_NOERR) then + rc = NF90_get_att(ncid, varid, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading "//trim(att_str)) + endif endif endif if (present(found)) found = (rc == NF90_NOERR) @@ -815,6 +934,10 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re ! Communicate the string length info(1) = att_len ; info(2) = 0 ; if (do_read .and. found) info(2) = 1 call broadcast(info, 2, blocking=.true.) + if (present(found)) then + found = (info(2) /= 0) + if (.not. found) return + endif att_len = info(1) if (att_len > 0) then @@ -824,7 +947,6 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re if (do_read) tmp_str(1) = att_val call broadcast(tmp_str, att_len, blocking=.true.) att_val = tmp_str(1) - if (present(found)) found = (info(2) /= 0) elseif (.not.allocated(att_val)) then allocate(character(4) :: att_val) ; att_val = '' endif @@ -1197,21 +1319,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 +1350,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 +1371,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 +1382,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 +1404,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 +1438,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 +1560,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 +1575,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 +1606,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 +1622,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 +1657,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 +1692,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 +1726,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 +1755,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 +1951,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..74db4e0f95 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,14 +847,14 @@ 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 + integer :: num_files ! The number of restart files that will be used. 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 - integer :: length + character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs + integer :: length ! The length of a text string. integer(kind=8) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos integer :: turns @@ -931,24 +903,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 +913,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) @@ -969,7 +924,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ endif endif - restartpath = trim(directory)// trim(restartname) + restartpath = trim(directory) // trim(restartname) if (num_files < 10) then write(suffix,'("_",I1)') num_files @@ -977,7 +932,16 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ write(suffix,'("_",I2)') num_files endif - if (num_files > 0) restartpath = trim(restartpath) // trim(suffix) + length = len_trim(restartpath) + if (length < 3) then ! This case is very uncommon but this test avoids segmentation-faults. + if (num_files > 0) restartpath = trim(restartpath) // suffix + restartpath = trim(restartpath)//".nc" + elseif (restartpath(length-2:length) == ".nc") then + if (num_files > 0) restartpath = restartpath(1:length-3)//trim(suffix)//".nc" + else + if (num_files > 0) restartpath = trim(restartpath) // suffix + restartpath = trim(restartpath)//".nc" + endif do m=start_var,next_var-1 vars(m-start_var+1) = CS%restart_field(m)%vars @@ -1059,20 +1023,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 +1060,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 +1075,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 +1090,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 +1109,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 +1223,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 +1240,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 +1267,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 +1285,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 +1298,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 +1315,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 +1366,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 +1389,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 +1427,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 +1441,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 +1624,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/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index fea1ac4910..dbcd2405ec 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -54,8 +54,8 @@ module MOM_unit_scaling !> Allocates and initializes the ocean model unit scaling type subroutine unit_scaling_init( param_file, US ) - type(param_file_type), optional, intent(in) :: param_file !< Parameter file handle/type - type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handle/type + type(unit_scale_type), pointer :: US !< A dimensional unit scaling type ! This routine initializes a unit_scale_type structure (US). @@ -66,39 +66,33 @@ subroutine unit_scaling_init( param_file, US ) # include "version_variable.h" character(len=16) :: mdl = "MOM_unit_scaling" - if (.not.present(US)) return - if (associated(US)) call MOM_error(FATAL, & 'unit_scaling_init: called with an associated US pointer.') allocate(US) - if (present(param_file)) then - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, & - "Parameters for doing unit scaling of variables.", debugging=.true.) - call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & - "An integer power of 2 that is used to rescale the model's "//& - "internal units of depths and heights. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & - "An integer power of 2 that is used to rescale the model's "//& - "internal units of lateral distances. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & - "An integer power of 2 that is used to rescale the model's "//& - "internal units of time. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & - "An integer power of 2 that is used to rescale the model's "//& - "internal units of density. Valid values range from -300 to 300.", & + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, & + "Parameters for doing unit scaling of variables.", debugging=.true.) + call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of depths and heights. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of lateral distances. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of time. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of density. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of heat content. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & - "An integer power of 2 that is used to rescale the model's "//& - "internal units of heat content. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) - else - Z_power = 0 ; L_power = 0 ; T_power = 0 ; R_power = 0 ; Q_power = 0 - endif if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "Z_RESCALE_POWER is outside of the valid range of -300 to 300.") diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 87ee49d449..7dc0124930 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1632,6 +1632,52 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif + ! Set up the restarts. + + call restart_init(param_file, CS%restart_CSp, "Shelf.res") + call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & + "Ice shelf mass", "kg m-2") + call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & + "Ice shelf area in cell", "m2") + call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & + "ice sheet/shelf thickness", "m") + if (PRESENT(sfc_state_in)) then + if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then + u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & + hor_grid='Cu',z_grid='1') + v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & + hor_grid='Cv',z_grid='1') + call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc, v_desc, & + .false., CS%restart_CSp) + endif + endif + + call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., CS%restart_CSp, & + "Height unit conversion factor", "Z meter-1") + call register_restart_field(US%m_to_L_restart, "m_to_L", .false., CS%restart_CSp, & + "Length unit conversion factor", "L meter-1") + call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., CS%restart_CSp, & + "Density unit conversion factor", "R m3 kg-1") + if (CS%active_shelf_dynamics) then + call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & + "ice sheet/shelf thickness mask" ,"none") + endif + + if (CS%active_shelf_dynamics) then + ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics + call register_ice_shelf_dyn_restarts(CS%Grid_in, param_file, CS%dCS, CS%restart_CSp) + endif + + !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file + !if (.not. CS%solo_ice_sheet) then + ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & + ! "Friction velocity under ice shelves", "m s-1") + !endif + + CS%restart_output_dir = dirs%restart_output_dir + + + if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then ! This model is initialized internally or from a file. call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file,& @@ -1652,8 +1698,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 @@ -1706,49 +1751,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif - ! Set up the restarts. - - call restart_init(param_file, CS%restart_CSp, "Shelf.res") - call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & - "Ice shelf mass", "kg m-2") - call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & - "Ice shelf area in cell", "m2") - call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & - "ice sheet/shelf thickness", "m") - if (PRESENT(sfc_state_in)) then - if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then - u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & - hor_grid='Cu',z_grid='1') - v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & - hor_grid='Cv',z_grid='1') - call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc, v_desc, & - .false., CS%restart_CSp) - endif - endif - - call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., CS%restart_CSp, & - "Height unit conversion factor", "Z meter-1") - call register_restart_field(US%m_to_L_restart, "m_to_L", .false., CS%restart_CSp, & - "Length unit conversion factor", "L meter-1") - call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., CS%restart_CSp, & - "Density unit conversion factor", "R m3 kg-1") - if (CS%active_shelf_dynamics) then - call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & - "ice sheet/shelf thickness mask" ,"none") - endif - - if (CS%active_shelf_dynamics) then - ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics - call register_ice_shelf_dyn_restarts(CS%Grid_in, param_file, CS%dCS, CS%restart_CSp) - endif - - !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file - !if (.not. CS%solo_ice_sheet) then - ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & - ! "Friction velocity under ice shelves", "m s-1") - !endif - - CS%restart_output_dir = dirs%restart_output_dir CS%Time = Time @@ -1763,16 +1765,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 @@ -1792,7 +1793,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, meltrate_conversion = 86400.0*365.0*US%Z_to_m*US%s_to_T / CS%density_ice endif CS%id_melt = register_diag_field('ice_shelf_model', 'melt', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Melt Rate', 'm yr-1', conversion= meltrate_conversion) + 'Ice Shelf Melt Rate', 'm yr-1', conversion=meltrate_conversion) CS%id_thermal_driving = register_diag_field('ice_shelf_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', 'Celsius') CS%id_haline_driving = register_diag_field('ice_shelf_model', 'haline_driving', CS%diag%axesT1, CS%Time, & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index cf6845599b..1f8d45e88d 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -11,7 +11,7 @@ module MOM_ice_shelf_dynamics !use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, set_IS_diag_mediator_grid use MOM_IS_diag_mediator, only : diag_ctrl, time_type, enable_averages, disable_averaging use MOM_domains, only : MOM_domains_init, clone_MOM_domain -use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER +use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER, CENTER use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type @@ -25,7 +25,8 @@ module MOM_ice_shelf_dynamics 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 - +use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_from_file,initialize_ice_C_basal_friction +use MOM_ice_shelf_initialize, only : initialize_ice_AGlen implicit none ; private #include @@ -78,6 +79,8 @@ module MOM_ice_shelf_dynamics !! on corner-points (B grid) [degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, often in [R L4 Z T-1 ~> kg m2 s-1]. + real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, + !!often in [R-1/3 L-2/3 Z-1/3 T-1 ~> kg-1/3 m-1/3 s-1]. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries !! [L yr-1 ~> m yr-1] @@ -86,10 +89,15 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. + real, pointer, dimension(:,:) :: bed_elev => NULL() !< The bed elevation used for ice dynamics [Z ~> m]. + !! the same as bathyT, when below sea-level. + !!Sign convention: positive below sea-level, negative above. + real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" !! basal stress [R Z L2 T-1 ~> kg s-1]. !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 - + real, pointer, dimension(:,:) :: C_basal_friction => NULL()!< Coefficient in sliding law tau_b = C u^(n_basal_fric), + !! units= Pa (m yr-1)-(n_basal_fric) real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. @@ -124,11 +132,8 @@ module MOM_ice_shelf_dynamics real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs !! i.e. dt <= CFL_factor * min(dx / u) - real :: A_glen_isothermal !< Ice viscosity parameter in Glen's Law, [Pa-3 s-1]. real :: n_glen !< Nonlinearity exponent in Glen's Law real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [year-1]. - real :: C_basal_friction !< Coefficient in sliding law tau_b = C u^(n_basal_fric), in - !! units= Pa (m yr-1)-(n_basal_fric) real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean !! circulation or thermodynamics. It is used to estimate the @@ -156,13 +161,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_taudx_shelf = -1, id_taudy_shelf = -1, id_bed_elev = -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 + id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1 !>@} ! ids for outputting intermediate thickness in advection subroutine (debugging) !>@{ Diagnostic handles for debugging - integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1, id_visc_shelf = -1 + integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1, & + id_visc_shelf = -1, id_taub = -1 !>@} type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. @@ -253,30 +259,43 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%v_shelf(:,:) = 0.0 allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 allocate( CS%ice_visc(isd:ied,jsd:jed) ) ; CS%ice_visc(:,:) = 0.0 + allocate( CS%AGlen_visc(isd:ied,jsd:jed) ) ; CS%AGlen_visc(:,:) = 2.261e-25 allocate( CS%basal_traction(isd:ied,jsd:jed) ) ; CS%basal_traction(:,:) = 0.0 + allocate( CS%C_basal_friction(isd:ied,jsd:jed) ) ; CS%C_basal_friction(:,:) = 5.0e10 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 + allocate( CS%taudx_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%taudx_shelf(:,:) = 0.0 + allocate( CS%taudy_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%taudy_shelf(:,:) = 0.0 + allocate( CS%bed_elev(isd:ied,jsd:jed) ) ; CS%bed_elev(:,:)=G%bathyT(:,:)!CS%bed_elev(:,:) = 0.0 + allocate( CS%u_bdry_val(IsdB:IedB,JsdB:JedB) ) ; CS%u_bdry_val(:,:) = 0.0 + allocate( CS%v_bdry_val(IsdB:IedB,JsdB:JedB) ) ; CS%v_bdry_val(:,:) = 0.0 + allocate( CS%u_face_mask_bdry(IsdB:IedB,JsdB:JedB) ) ; CS%u_face_mask_bdry(:,:) = -2.0 + allocate( CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB) ) ; CS%v_face_mask_bdry(:,:) = -2.0 + allocate( CS%h_bdry_val(isd:ied,jsd:jed) ) ; CS%h_bdry_val(:,:) = 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') call register_restart_field(CS%v_shelf, "v_shelf", .false., 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%u_bdry_val, "u_bdry", .false., restart_CS, & + "ice sheet/shelf boundary u-velocity", "m s-1", hor_grid='Bu') + call register_restart_field(CS%v_bdry_val, "v_bdry", .false., restart_CS, & + "ice sheet/shelf boundary v-velocity", "m s-1", hor_grid='Bu') + call register_restart_field(CS%u_face_mask_bdry, "u_bdry_mask", .false., restart_CS, & + "ice sheet/shelf boundary u-mask", "nondim", hor_grid='Bu') + call register_restart_field(CS%v_face_mask_bdry, "v_bdry_mask", .false., restart_CS, & + "ice sheet/shelf boundary v-mask", "nondim", hor_grid='Bu') + 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, & "fractional degree of grounding", "nondim") - call register_restart_field(CS%ice_visc, "viscosity", .true., restart_CS, & - "Volume integrated Glens law ice viscosity", "kg m2 s-1") - call register_restart_field(CS%basal_traction, "tau_b_beta", .true., restart_CS, & - "The area integrated basal traction coefficient", "kg s-1") + call register_restart_field(CS%C_basal_friction, "tau_b_beta", .true., restart_CS, & + "basal sliding coefficients", "Pa (m s-1)^n_sliding") + call register_restart_field(CS%AGlen_visc, "A_Glen", .true., restart_CS, & + "ice-stiffness parameter", "Pa-3 s-1") + call register_restart_field(CS%h_bdry_val, "h_bdry", .false., restart_CS, & + "ice thickness at the boundary","m") endif end subroutine register_ice_shelf_dyn_restarts @@ -376,10 +395,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) - call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & - "Ice viscosity parameter in Glen's Law", & - 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.) @@ -389,10 +404,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 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 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) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & @@ -425,15 +436,10 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! previously allocated for registration for restarts. if (active_shelf_dynamics) then - 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 - allocate( CS%h_bdry_val(isd:ied,jsd:jed) ) ; CS%h_bdry_val(:,:) = 0.0 allocate( CS%thickness_bdry_val(isd:ied,jsd:jed) ) ; CS%thickness_bdry_val(:,:) = 0.0 - allocate( CS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 - allocate( CS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 - allocate( CS%u_face_mask_bdry(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_bdry(:,:) = -2.0 - allocate( CS%v_face_mask_bdry(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask_bdry(:,:) = -2.0 + allocate( CS%u_face_mask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_face_mask(:,:) = 0.0 + allocate( CS%v_face_mask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 allocate( CS%u_flux_bdry_val(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_bdry_val(:,:) = 0.0 allocate( CS%v_flux_bdry_val(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_bdry_val(:,:) = 0.0 allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 @@ -526,62 +532,60 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%calve_mask,G%domain) 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 ) + ! initialize basal friction coefficients + call initialize_ice_C_basal_friction(CS%C_basal_friction, G, US, param_file) + call pass_var(CS%C_basal_friction, G%domain) + + ! initialize ice-stiffness AGlen + call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) + call pass_var(CS%AGlen_visc, G%domain) + + !initialize boundary conditions + call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, 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 pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + + !initialize ice flow velocities from file + call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf,CS%ground_frac, ISS%hmask,ISS%h_shelf, & + G, US, param_file) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) + call pass_var(CS%bed_elev, G%domain,CENTER) 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('ice_shelf_model','u_shelf',CS%diag%axesCu1, Time, & + CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesB1, 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('ice_shelf_model','v_shelf',CS%diag%axesCv1, Time, & + CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesB1, Time, & 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) - CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesT1, Time, & + ! I think that the conversion factors for the next two diagnostics are wrong. - RWH + CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesB1, 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, & + CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesB1, Time, & + 'y-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%axesB1, Time, & 'mask for u-nodes', 'none') - CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesCv1, Time, & + CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesB1, Time, & 'mask for v-nodes', 'none') 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('ice_shelf_model','col_thick',CS%diag%axesT1, Time, & 'ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) 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_taub = register_diag_field('ice_shelf_model','taub_beta',CS%diag%axesT1, Time, & + 'taub', 'Pa yr m-1', 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('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 @@ -600,7 +604,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) real :: rhoi_rhow real :: OD ! Depth of open water below the ice shelf [Z ~> m] type(time_type) :: dummy_time - +! rhoi_rhow = CS%density_ice / CS%density_ocean_avg dummy_time = set_time(0,0) isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -694,23 +698,26 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled 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) +! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) if (update_ice_vel) then call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) 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_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_taub > 0) call post_data(CS%id_taub, CS%basal_traction,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) - if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) + if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask,CS%u_face_mask_bdry,CS%diag) + if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask,CS%v_face_mask_bdry,CS%diag) +! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) call disable_averaging(CS%diag) @@ -769,7 +776,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! 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) +! 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 @@ -777,7 +784,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! 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) +! 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 @@ -872,7 +879,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite 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) +! 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 @@ -919,7 +926,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite ! This makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) +! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & @@ -930,7 +938,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite 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) + call pass_vector(Au,Av,G%domain,TO_ALL,BGRID_NE) + 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 @@ -968,10 +977,11 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite 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 + do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) +! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 @@ -1212,6 +1222,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 @@ -1316,8 +1327,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! 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 @@ -1341,8 +1350,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H enddo call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - - if (conv_flag == 0) then + if (conv_flag == 0) then iters = CS%cg_max_iterations endif @@ -1812,7 +1820,8 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! prelim - go through and calculate S ! or is this faster? - BASE(:,:) = -G%bathyT(:,:) + OD(:,:) + !BASE(:,:) = -G%bathyT(:,:) + OD(:,:) + BASE(:,:) = -CS%bed_elev(:,:) + OD(:,:) S(:,:) = BASE(:,:) + ISS%h_shelf(:,:) ! check whether the ice is floating or grounded @@ -2069,7 +2078,7 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas 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(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. @@ -2078,10 +2087,10 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas !! shelf is floating: 0 if floating, 1 if not. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. - ! and/or whether flow is "hybridized" + real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors @@ -2243,13 +2252,14 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -2298,7 +2308,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & 0.25 * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) @@ -2391,13 +2401,14 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law. The exact form and units depend on the !! basal law exponent. [R L4 Z T-1 ~> kg m2 s-1]. - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -2517,8 +2528,7 @@ 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) - + 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 @@ -2560,12 +2570,14 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) 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) + CS%ice_visc(:,:)=1e22 +! 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 + Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%AGlen_visc(i,j))**(-1./CS%n_glen) + 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)) - & @@ -2574,6 +2586,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (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) =1e14*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging 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 @@ -2614,12 +2627,12 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) 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)) - CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) +! CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) + CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) endif enddo enddo @@ -2892,9 +2905,9 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: vmask !< A coded mask indicating the nature of the !! meridional flow at the corner point - real, dimension(SZDIB_(G),SZDJ_(G)), & +real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face - real, dimension(SZDI_(G),SZDJB_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face ! sets masks for velocity solve ! ignores the fact that their might be ice-free cells - this only considers the computational boundary @@ -3064,7 +3077,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) enddo enddo - call pass_var(H_node, G%domain, position=CORNER) + call pass_var(H_node, G%domain,position=CORNER) end subroutine interpolate_H_to_B @@ -3075,13 +3088,16 @@ subroutine ice_shelf_dyn_end(CS) if (.not.associated(CS)) return deallocate(CS%u_shelf, CS%v_shelf) + deallocate(CS%taudx_shelf, CS%taudy_shelf) deallocate(CS%t_shelf, CS%tmask) - deallocate(CS%u_bdry_val, CS%v_bdry_val, CS%t_bdry_val) + deallocate(CS%u_bdry_val, CS%v_bdry_val) deallocate(CS%u_face_mask, CS%v_face_mask) deallocate(CS%umask, CS%vmask) - deallocate(CS%ice_visc, CS%basal_traction) + deallocate(CS%ice_visc, CS%AGlen_visc) + deallocate(CS%basal_traction,CS%C_basal_friction) deallocate(CS%OD_rt, CS%OD_av) + deallocate(CS%t_bdry_val, CS%bed_elev) deallocate(CS%ground_frac, CS%ground_frac_rt) deallocate(CS) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 7a59d1586d..f3a5f210fc 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -7,7 +7,7 @@ module MOM_ice_shelf_initialize use MOM_array_transform, only : rotate_array use MOM_hor_index, only : hor_index_type use MOM_file_parser, only : get_param, read_param, log_param, param_file_type -use MOM_io, only: MOM_read_data, file_exists, slasher +use MOM_io, only: MOM_read_data, file_exists, slasher, CORNER use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_unit_scaling, only : unit_scale_type use user_shelf_init, only: USER_init_ice_thickness @@ -19,7 +19,9 @@ module MOM_ice_shelf_initialize public initialize_ice_thickness public initialize_ice_shelf_boundary_channel public initialize_ice_flow_from_file - +public initialize_ice_shelf_boundary_from_file +public initialize_ice_C_basal_friction +public initialize_ice_AGlen ! 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 ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units @@ -261,13 +263,15 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b US, PF ) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G)), & + real, dimension(SZIB_(G),SZJB_(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)), & + real, dimension(SZIB_(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]. @@ -283,6 +287,7 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b 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)), & @@ -375,15 +380,18 @@ 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,& +subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& hmask,h_shelf, G, US, PF) +!subroutine initialize_ice_flow_from_file(bed_elev,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]. + intent(inout) :: bed_elev !< The ice shelf u velocity [Z ~> m]. + 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) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -398,8 +406,9 @@ subroutine initialize_ice_flow_from_file(u_shelf, v_shelf,ice_visc,float_cond,& ! 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=200) :: filename,vel_file,inputdir,bed_topo_file ! Strings for file/path + character(len=200) :: ushelf_varname, vshelf_varname, & + ice_visc_varname, floatfr_varname, bed_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 @@ -426,26 +435,236 @@ subroutine initialize_ice_flow_from_file(u_shelf, v_shelf,ice_visc,float_cond,& call get_param(PF, mdl, "ICE_VISC_VARNAME", ice_visc_varname, & "The name of the thickness variable in ICE_VELOCITY_FILE.", & default="viscosity") - + call get_param(PF, mdl, "BED_TOPO_FILE", bed_topo_file, & + "The file from which the velocity is read.", & + default="ice_shelf_vel.nc") + call get_param(PF, mdl, "BED_TOPO_VARNAME", bed_varname, & + "The name of the thickness variable in ICE_VELOCITY_FILE.", & + default="depth") 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(ushelf_varname), u_shelf, G%Domain, position=CORNER,scale=1.0) + call MOM_read_data(filename,trim(vshelf_varname), v_shelf, G%Domain, position=CORNER,scale=1.0) +! call MOM_read_data(filename,trim(ice_visc_varname), ice_visc, G%Domain,position=CORNER,scale=1.0) call MOM_read_data(filename,trim(floatfr_varname), float_cond, G%Domain, scale=1.) + filename = trim(inputdir)//trim(bed_topo_file) + call MOM_read_data(filename,trim(bed_varname), bed_elev, 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 + +!> Initialize ice shelf b.c.s from file +subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask_bdry, & + u_bdry_val, v_bdry_val, umask, vmask, 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),SZJB_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces + 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 + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: umask !< A mask foor ice shelf velocity + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: vmask !< A mask foor ice shelf velocity + 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=200) :: filename, bc_file, inputdir, icethick_file ! Strings for file/path + character(len=200) :: ufcmskbdry_varname, vfcmskbdry_varname, & + ubdryv_varname, vbdryv_varname, umask_varname, vmask_varname, & + h_varname,hmsk_varname ! Variable name in file + character(len=40) :: mdl = "initialize_ice_shelf_boundary_from_file" ! This subroutine's name. + + integer :: i, j, isc, jsc, iec, jec + + h_bdry_val(:,:) = 0. + thickness_bdry_val(:,:) = 0. + + call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_b_c_s_from_file: reading b.c.s") + + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(PF, mdl, "ICE_SHELF_BC_FILE", bc_file, & + "The file from which the boundary conditions are read.", & + default="ice_shelf_bc.nc") + call get_param(PF, mdl, "ICE_THICKNESS_FILE", icethick_file, & + "The file from which the ice-shelf thickness is read.", & + default="ice_shelf_thick.nc") + call get_param(PF, mdl, "ICE_THICKNESS_VARNAME", h_varname, & + "The name of the thickness variable in ICE_THICKNESS_FILE.", & + default="h_shelf") + call get_param(PF, mdl, "ICE_THICKNESS_MASK_VARNAME", hmsk_varname, & + "The name of the icethickness mask variable in ICE_THICKNESS_FILE.", & + default="h_mask") + + filename = trim(inputdir)//trim(bc_file) + call log_param(PF, mdl, "INPUTDIR/ICE_SHELF_BC_FILE", filename) + call get_param(PF, mdl, "ICE_UBDRYMSK_VARNAME", ufcmskbdry_varname, & + "The name of the ice-shelf ubdrymask variable in ICE_SHELF_BC_FILE.", & + default="ufacemask") + call get_param(PF, mdl, "ICE_VBDRYMSK_VARNAME", vfcmskbdry_varname, & + "The name of the ice-shelf vbdrymask variable in ICE_SHELF_BC_FILE.", & + default="vfacemask") + call get_param(PF, mdl, "ICE_UMASK_VARNAME", umask_varname, & + "The name of the ice-shelf ubdrymask variable in ICE_SHELF_BC_FILE.", & + default="umask") + call get_param(PF, mdl, "ICE_VMASK_VARNAME", vmask_varname, & + "The name of the ice-shelf vbdrymask variable in ICE_SHELF_BC_FILE.", & + default="vmask") + call get_param(PF, mdl, "ICE_UBDRYVAL_VARNAME", ubdryv_varname, & + "The name of the ice-shelf ice_shelf ubdry variable in ICE_SHELF_BC_FILE.", & + default="ubdry_val") + call get_param(PF, mdl, "ICE_VBDRYVAL_VARNAME", vbdryv_varname, & + "The name of the ice-shelf ice_shelf vbdry variable in ICE_SHELF_BC_FILE.", & + default="vbdry_val") + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) + + + call MOM_read_data(filename, trim(ufcmskbdry_varname),u_face_mask_bdry, G%Domain,position=CORNER,scale=1.0) + call MOM_read_data(filename,trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER,scale=1.0) + call MOM_read_data(filename,trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER,scale=1.0) + call MOM_read_data(filename,trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER,scale=1.) + call MOM_read_data(filename,trim(umask_varname), umask, G%Domain, position=CORNER,scale=1.) + call MOM_read_data(filename,trim(vmask_varname), vmask, G%Domain, position=CORNER,scale=1.) + filename = trim(inputdir)//trim(icethick_file) + + call MOM_read_data(filename, trim(h_varname), h_shelf, G%Domain, scale=US%m_to_Z) + call MOM_read_data(filename,trim(hmsk_varname), hmask, 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)) + if (hmask(i,j) == 3.) then + thickness_bdry_val(i,j) = h_shelf(i,j) + h_bdry_val(i,j) = h_shelf(i,j) endif enddo enddo -end subroutine initialize_ice_flow_from_file +end subroutine initialize_ice_shelf_boundary_from_file + +!> Initialize ice basal friction +subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: C_basal_friction !< Ice-stream basal friction + 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 + +! integer :: i, j + real :: C_friction + character(len=40) :: mdl = "initialize_ice_basal_friction" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, C_friction_file + + call get_param(PF, mdl, "ICE_BASAL_FRICTION_CONFIG", config, & + "This specifies how the initial basal friction profile is specified. "//& + "Valid values are: CONSTANT and FILE.", & + fail_if_missing=.true.) + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "BASAL_FRICTION_COEFF", C_friction, & + "Coefficient in sliding law.", units="Pa (m s-1)^(n_basal_fric)", default=5.e10) + + C_basal_friction(:,:) = C_friction + elseif (trim(config)=="FILE") then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading friction coefficients") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & + "The file from which basal friction coefficients are read.", & + default="ice_basal_friction.nc") + filename = trim(inputdir)//trim(C_friction_file) + call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTION_FILE", filename) + + call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & + "The variable to use in basal traction.", & + default="tau_b_beta") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_basal_friction_from_file: Unable to open "//trim(filename)) + + call MOM_read_data(filename,trim(varname),C_basal_friction,G%Domain) + + endif +end subroutine + + +!> Initialize ice basal friction +subroutine initialize_ice_AGlen(AGlen, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen + 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 + +! integer :: i, j + real :: A_Glen + character(len=40) :: mdl = "initialize_ice_stiffness" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, AGlen_file + + call get_param(PF, mdl, "ICE_A_GLEN_CONFIG", config, & + "This specifies how the initial ice-stiffness parameter is specified. "//& + "Valid values are: CONSTANT and FILE.", & + fail_if_missing=.true.) + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "A_GLEN", A_Glen, & + "Ice-stiffness parameter.", units="Pa-3 s-1", default=2.261e-25) + + AGlen(:,:) = A_Glen + + elseif (trim(config)=="FILE") then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading ice-stiffness parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(PF, mdl, "ICE_STIFFNESS_FILE", AGlen_file, & + "The file from which the ice-stiffness is read.", & + default="ice_AGlen.nc") + filename = trim(inputdir)//trim(AGlen_file) + call log_param(PF, mdl, "INPUTDIR/ICE_STIFFNESS_FILE", filename) + call get_param(PF, mdl, "A_GLEN_VARNAME", varname, & + "The variable to use as ice-stiffness.", & + default="A_GLEN") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_stiffness_from_file: Unable to open "//trim(filename)) + call MOM_read_data(filename,trim(varname),AGlen,G%Domain) + + endif +end subroutine end module MOM_ice_shelf_initialize diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 0fac3e15b4..fbee77d130 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -9,7 +9,7 @@ module MOM_grid_initialize use MOM_domains, only : To_North, To_South, To_East, To_West use MOM_domains, only : MOM_domain_type, clone_MOM_domain, deallocate_MOM_domain use MOM_dyn_horgrid, only : dyn_horgrid_type, set_derived_dyn_horgrid -use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_io, only : MOM_read_data, slasher, file_exists, stdout @@ -1217,11 +1217,17 @@ subroutine initialize_masks(G, PF, US) units="m", default=0.0, scale=m_to_Z_scale) call get_param(PF, mdl, "MASKING_DEPTH", mask_depth, & "The depth below which to mask points as land points, for which all "//& - "fluxes are zeroed out. MASKING_DEPTH is ignored if negative.", & + "fluxes are zeroed out. MASKING_DEPTH needs to be smaller than MINIMUM_DEPTH", & units="m", default=-9999.0, scale=m_to_Z_scale) + if (mask_depth > min_depth) then + mask_depth = -9999.0*m_to_Z_scale + call MOM_error(WARNING, "MOM_grid_init: initialize_masks "//& + 'MASKING_DEPTH is larger than MINIMUM_DEPTH and therefore ignored.') + endif + Dmin = min_depth - if (mask_depth>=0.) Dmin = mask_depth + if (mask_depth /= -9999.*m_to_Z_scale) Dmin = mask_depth G%mask2dCu(:,:) = 0.0 ; G%mask2dCv(:,:) = 0.0 ; G%mask2dBu(:,:) = 0.0 diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index ee80bbdace..336a85d5bc 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -413,17 +413,27 @@ subroutine limit_topography(D, G, param_file, max_depth, US) "The depth below which to mask the ocean as land.", & units="m", default=-9999.0, scale=m_to_Z, do_not_log=.true.) -! Make sure that min_depth < D(x,y) < max_depth - if (mask_depth < -9990.*m_to_Z) then - do j=G%jsd,G%jed ; do i=G%isd,G%ied - D(i,j) = min( max( D(i,j), 0.5*min_depth ), max_depth ) - enddo ; enddo + if (mask_depth > min_depth) then + mask_depth = -9999.0*m_to_Z + call MOM_error(WARNING, "MOM_shared_initialization: limit_topography "//& + 'MASKING_DEPTH is larger than MINIMUM_DEPTH and therefore ignored.') + endif + + ! Make sure that min_depth < D(x,y) < max_depth for ocean points + if (mask_depth == -9999.*m_to_Z) then + if (min_depth > 0.0) then ! This is retained to avoid answer changes (over the land points) in the test cases. + do j=G%jsd,G%jed ; do i=G%isd,G%ied + D(i,j) = min( max( D(i,j), 0.5*min_depth ), max_depth ) + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + D(i,j) = min( max( D(i,j), min_depth ), max_depth ) + enddo ; enddo + endif else do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (D(i,j)>0.) then + if (D(i,j) > mask_depth) then D(i,j) = min( max( D(i,j), min_depth ), max_depth ) - else - D(i,j) = 0. endif enddo ; enddo endif @@ -478,11 +488,13 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) integer :: I, J real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] real :: beta ! The meridional gradient of the Coriolis parameter [T-1 m-1 ~> s-1 m-1] + real :: beta_lat_ref ! The reference latitude for the beta plane [degrees/km/m/cm] real :: y_scl, Rad_Earth real :: T_to_s ! A time unit conversion factor real :: PI character(len=40) :: mdl = "set_rotation_beta_plane" ! This subroutine's name. character(len=200) :: axis_units + character(len=40) :: beta_lat_ref_units call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") @@ -501,16 +513,24 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) case ("d") call get_param(param_file, mdl, "RAD_EARTH", Rad_Earth, & "The radius of the Earth.", units="m", default=6.378e6) - y_scl = Rad_Earth/PI - case ("k"); y_scl = 1.E3 - case ("m"); y_scl = 1. - case ("c"); y_scl = 1.E-2 + beta_lat_ref_units = "degrees" + y_scl = PI * Rad_Earth/ 180. + case ("k") + beta_lat_ref_units = "kilometers" + y_scl = 1.E3 + case ("m") + beta_lat_ref_units = "meters" + y_scl = 1. case default ; call MOM_error(FATAL, & " set_rotation_beta_plane: unknown AXIS_UNITS = "//trim(axis_units)) end select + call get_param(param_file, mdl, "BETA_LAT_REF", beta_lat_ref, & + "The reference latitude (origin) of the beta-plane", & + units=trim(beta_lat_ref_units), default=0.0) + do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB - f(I,J) = f_0 + beta * ( G%geoLatBu(I,J) * y_scl ) + f(I,J) = f_0 + beta * ( (G%geoLatBu(I,J) - beta_lat_ref) * y_scl ) enddo ; enddo call callTree_leave(trim(mdl)//'()') @@ -1194,17 +1214,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()') @@ -1213,6 +1234,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 @@ -1244,13 +1271,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) @@ -1265,7 +1291,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) @@ -1300,6 +1326,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 322bc8faef..0f8c772348 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 @@ -194,7 +194,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_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 850f94cff2..762b2edaea 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1421,26 +1421,23 @@ subroutine MEKE_alloc_register_restart(HI, param_file, MEKE, restart_CS) end subroutine MEKE_alloc_register_restart -!> Deallocates any variables allocated in MEKE_init or -!! MEKE_alloc_register_restart. -subroutine MEKE_end(MEKE, CS) - type(MEKE_type), pointer :: MEKE !< A structure with MEKE-related fields. - type(MEKE_CS), pointer :: CS !< The control structure for MOM_MEKE. +!> Deallocates any variables allocated in MEKE_alloc_register_restart. +subroutine MEKE_end(MEKE) + type(MEKE_type), intent(inout) :: MEKE !< A structure with MEKE-related fields. - if (associated(CS)) deallocate(CS) + ! NOTE: MEKE will always be allocated by MEKE_init, even if MEKE is disabled. + ! So these must all be conditional, even though MEKE%MEKE and MEKE%Rd_dx_h + ! are always allocated (when MEKE is enabled) - if (.not.associated(MEKE)) return - - if (associated(MEKE%MEKE)) deallocate(MEKE%MEKE) - if (associated(MEKE%GM_src)) deallocate(MEKE%GM_src) - if (associated(MEKE%mom_src)) deallocate(MEKE%mom_src) - if (associated(MEKE%GME_snk)) deallocate(MEKE%GME_snk) - if (associated(MEKE%Kh)) deallocate(MEKE%Kh) + if (associated(MEKE%Au)) deallocate(MEKE%Au) if (associated(MEKE%Kh_diff)) deallocate(MEKE%Kh_diff) if (associated(MEKE%Ku)) deallocate(MEKE%Ku) - if (associated(MEKE%Au)) deallocate(MEKE%Au) - deallocate(MEKE) - + if (associated(MEKE%Rd_dx_h)) deallocate(MEKE%Rd_dx_h) + if (associated(MEKE%Kh)) deallocate(MEKE%Kh) + if (associated(MEKE%GME_snk)) deallocate(MEKE%GME_snk) + if (associated(MEKE%mom_src)) deallocate(MEKE%mom_src) + if (associated(MEKE%GM_src)) deallocate(MEKE%GM_src) + if (associated(MEKE%MEKE)) deallocate(MEKE%MEKE) end subroutine MEKE_end !> \namespace mom_meke diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 5bbc495e93..c588a1faa4 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -187,6 +187,7 @@ module MOM_hor_visc integer :: id_grid_Re_Ah = -1, id_grid_Re_Kh = -1 integer :: id_diffu = -1, id_diffv = -1 ! integer :: id_hf_diffu = -1, id_hf_diffv = -1 + integer :: id_h_diffu = -1, id_h_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 @@ -277,9 +278,8 @@ 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, hf_diffv_2d ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] - real, dimension(SZIB_(G),SZJ_(G)) :: intz_diffu_2d ! Depth-integral of diffu [L2 T-2 ~> m2 s-2] - real, dimension(SZI_(G),SZJB_(G)) :: intz_diffv_2d ! Depth-integral of diffv [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_diffu ! h x diffu [H L T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_diffv ! h x diffv [H L T-2 ~> m2 s-2] real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] @@ -309,7 +309,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] @@ -318,7 +317,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] @@ -389,6 +387,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 [H L 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 [H L 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 @@ -505,8 +511,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 ) & @@ -1645,38 +1650,58 @@ 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 - if (present(ADp) .and. (CS%id_intz_diffu_2d > 0)) then - intz_diffu_2d(:,:) = 0.0 + if (present(ADp) .and. (CS%id_h_diffu > 0)) then + allocate(h_diffu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_diffu(:,:,:) = 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) + h_diffu(I,j,k) = 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) + call post_data(CS%id_h_diffu, h_diffu, CS%diag) + deallocate(h_diffu) endif - if (present(ADp) .and. (CS%id_intz_diffv_2d > 0)) then - intz_diffv_2d(:,:) = 0.0 + if (present(ADp) .and. (CS%id_h_diffv > 0)) then + allocate(h_diffv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_diffv(:,:,:) = 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) + h_diffv(i,J,k) = 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) + call post_data(CS%id_h_diffv, h_diffv, CS%diag) + deallocate(h_diffv) endif end subroutine horizontal_viscosity @@ -2366,45 +2391,59 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, MEKE, ADp) 'Meridional Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) !CS%id_hf_diffu = register_diag_field('ocean_model', 'hf_diffu', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !if ((CS%id_hf_diffu > 0) .and. (present(ADp))) then ! call safe_alloc_ptr(CS%hf_diffu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) ! call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) !endif !CS%id_hf_diffv = register_diag_field('ocean_model', 'hf_diffv', diag%axesCvL, Time, & - ! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !if ((CS%id_hf_diffv > 0) .and. (present(ADp))) then ! call safe_alloc_ptr(CS%hf_diffv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) ! call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) !endif CS%id_hf_diffu_2d = register_diag_field('ocean_model', 'hf_diffu_2d', diag%axesCu1, Time, & - 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) if ((CS%id_hf_diffu_2d > 0) .and. (present(ADp))) then call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) endif CS%id_hf_diffv_2d = register_diag_field('ocean_model', 'hf_diffv_2d', diag%axesCv1, Time, & - 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) if ((CS%id_hf_diffv_2d > 0) .and. (present(ADp))) then 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', & + CS%id_h_diffu = register_diag_field('ocean_model', 'h_diffu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Horizontal Viscosity', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if ((CS%id_h_diffu > 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_h_diffv = register_diag_field('ocean_model', 'h_diffv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Horizontal Viscosity', 'm2 s-2', & conversion=GV%H_to_m*US%L_T2_to_m_s2) + if ((CS%id_h_diffv > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hv,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) + '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 @@ -2470,6 +2509,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, MEKE, ADp) if (CS%Laplacian .or. get_all) then endif end subroutine hor_visc_init + !> Calculates factors in the anisotropic orientation tensor to be align with the grid. !! With n1=1 and n2=0, this recovers the approach of Large et al, 2001. subroutine align_aniso_tensor_to_grid(CS, n1, n2) @@ -2486,6 +2526,7 @@ subroutine align_aniso_tensor_to_grid(CS, n1, n2) CS%n1n1_m_n2n2_h(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm CS%n1n1_m_n2n2_q(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm end subroutine align_aniso_tensor_to_grid + !> Apply a 1-1-4-1-1 Laplacian filter one time on GME diffusive flux to reduce any !! horizontal two-grid-point noise subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) @@ -2550,6 +2591,7 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) endif enddo ! s-loop end subroutine smooth_GME + !> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) type(hor_visc_CS), pointer :: CS !< The control structure returned by a @@ -2581,10 +2623,10 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%Ah_Max_xx) ; DEALLOC_(CS%Ah_Max_xy) endif if (CS%Smagorinsky_Ah) then - DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) + DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) endif if (CS%Leith_Ah) then - DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) + DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) endif if (CS%Re_Ah > 0.0) then DEALLOC_(CS%Re_Ah_const_xx) ; DEALLOC_(CS%Re_Ah_const_xy) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 80543d5968..8c08691675 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -1389,7 +1389,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) real, dimension(SZIB_(G)) :: & cg_p, cg_m, flux1, flux2 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p - real, dimension(SZI_(G),SZJB_(G),Nangle) :: & + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & Fdt_m, Fdt_p! Left and right energy fluxes [J] integer :: i, j, k, ish, ieh, jsh, jeh, a @@ -1464,7 +1464,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) real, dimension(SZI_(G)) :: & cg_p, cg_m, flux1, flux2 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p - real, dimension(SZI_(G),SZJB_(G),Nangle) :: & + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & Fdt_m, Fdt_p! South and north energy fluxes [J] character(len=160) :: mesg ! The text of an error message integer :: i, j, k, ish, ieh, jsh, jeh, a @@ -1653,9 +1653,16 @@ subroutine reflect(En, NAngle, CS, G, LB) angle_i(a) = Angle_size * real(a - 1) ! for a=1 aligned with x-axis enddo - angle_c = CS%refl_angle - part_refl = CS%refl_pref - ridge = CS%refl_dbl + ! init local arrays + angle_c(:,:) = CS%nullangle + part_refl(:,:) = 0. + ridge(:,:) = .false. + + do j=jsh,jeh ; do i=ish,ieh + angle_c(i,j) = CS%refl_angle(i,j) + part_refl(i,j) = CS%refl_pref(i,j) + ridge(i,j) = CS%refl_dbl(i,j) + enddo ; enddo En_reflected(:) = 0.0 do j=jsh,jeh ; do i=ish,ieh @@ -2317,7 +2324,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 +2344,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 +2363,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 +2391,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 +2412,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 +2425,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 +2434,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 7d95c43b98..fb70f5d679 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -55,6 +55,11 @@ module MOM_lateral_mixing_coeffs !! This parameter is set depending on other parameters. logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rate. !! This parameter is set depending on other parameters. + logical :: use_simpler_Eady_growth_rate !< If true, use a simpler method to calculate the + !! Eady growth rate that avoids division by layer thickness. + !! This parameter is set depending on other parameters. + real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or + !! incropped interfaces for the Eady growth rate calc [Z ~> m] real, dimension(:,:), pointer :: & SN_u => NULL(), & !< S*N at u-points [T-1 ~> s-1] SN_v => NULL(), & !< S*N at v-points [T-1 ~> s-1] @@ -111,6 +116,7 @@ module MOM_lateral_mixing_coeffs logical :: use_Visbeck !< Use Visbeck formulation for thickness diffusivity integer :: VarMix_Ktop !< Top layer to start downward integrals real :: Visbeck_L_scale !< Fixed length scale in Visbeck formula + real :: Eady_GR_D_scale !< Depth over which to average SN [Z ~> m] real :: Res_coef_khth !< A non-dimensional number that determines the function !! of resolution, used for thickness and tracer mixing, as: !! F = 1 / (1 + (Res_coef_khth*Ld/dx)^Res_fn_power) @@ -137,6 +143,7 @@ module MOM_lateral_mixing_coeffs !! Diagnostic identifier integer :: id_SN_u=-1, id_SN_v=-1, id_L2u=-1, id_L2v=-1, id_Res_fn = -1 integer :: id_N2_u=-1, id_N2_v=-1, id_S2_u=-1, id_S2_v=-1 + integer :: id_dzu=-1, id_dzv=-1, id_dzSxN=-1, id_dzSyN=-1 integer :: id_Rd_dx=-1, id_KH_u_QG = -1, id_KH_v_QG = -1 type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -147,7 +154,7 @@ module MOM_lateral_mixing_coeffs logical :: debug !< If true, write out checksums of data for debugging end type VarMix_CS -public VarMix_init, calc_slope_functions, calc_resoln_function +public VarMix_init, VarMix_end, calc_slope_functions, calc_resoln_function public calc_QG_Leith_viscosity, calc_depth_function contains @@ -445,40 +452,55 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) ! Local variables real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & e ! The interface heights relative to mean sea level [Z ~> m]. - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [T-2 ~> s-2] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [T-2 ~> s-2] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions:"//& "Module must be initialized before it is used.") if (CS%calculate_Eady_growth_rate) then - call find_eta(h, tv, G, GV, US, e, halo_size=2) - if (CS%use_stored_slopes) then + if (CS%use_simpler_Eady_growth_rate) then + call find_eta(h, tv, G, GV, US, e, halo_size=2) call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & - CS%slope_x, CS%slope_y, N2_u, N2_v, 1, OBC=OBC) - call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC=OBC) -! call calc_slope_functions_using_just_e(h, G, CS, e, .false.) + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, dzu=dzu, dzv=dzv, & + dzSxN=dzSxN, dzSyN=dzSyN, halo=1, OBC=OBC) + call calc_Eady_growth_rate_2D(CS, G, GV, US, OBC, h, e, dzu, dzv, dzSxN, dzSyN, CS%SN_u, CS%SN_v) else - !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true., OBC=OBC) + call find_eta(h, tv, G, GV, US, e, halo_size=2) + if (CS%use_stored_slopes) then + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, halo=1, OBC=OBC) + call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC=OBC) + else + !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true., OBC=OBC) + endif endif endif if (query_averaging_enabled(CS%diag)) then + if (CS%id_dzu > 0) call post_data(CS%id_dzu, dzu, CS%diag) + if (CS%id_dzv > 0) call post_data(CS%id_dzv, dzv, CS%diag) + if (CS%id_dzSxN > 0) call post_data(CS%id_dzSxN, dzSxN, CS%diag) + if (CS%id_dzSyN > 0) call post_data(CS%id_dzSyN, dzSyN, CS%diag) if (CS%id_SN_u > 0) call post_data(CS%id_SN_u, CS%SN_u, CS%diag) if (CS%id_SN_v > 0) call post_data(CS%id_SN_v, CS%SN_v, CS%diag) if (CS%id_L2u > 0) call post_data(CS%id_L2u, CS%L2u, CS%diag) if (CS%id_L2v > 0) call post_data(CS%id_L2v, CS%L2v, CS%diag) - if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then - if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) - if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) - endif + if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) + if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) endif end subroutine calc_slope_functions -!> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al. -subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, OBC) +!> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al., 1997. +!! This is on older implementation that is susceptible to large values of Eady growth rate +!! for incropping layers. +subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] @@ -632,14 +654,195 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O endif if (CS%debug) then - call uvchksum("calc_Visbeck_coeffs slope_[xy]", slope_x, slope_y, G%HI, haloshift=1) - call uvchksum("calc_Visbeck_coeffs N2_u, N2_v", N2_u, N2_v, G%HI, & + call uvchksum("calc_Visbeck_coeffs_old slope_[xy]", slope_x, slope_y, G%HI, haloshift=1) + call uvchksum("calc_Visbeck_coeffs_old N2_u, N2_v", N2_u, N2_v, G%HI, & scale=US%s_to_T**2, scalar_pair=.true.) - call uvchksum("calc_Visbeck_coeffs SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & + call uvchksum("calc_Visbeck_coeffs_old SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & + scale=US%s_to_T, scalar_pair=.true.) + endif + +end subroutine calc_Visbeck_coeffs_old + +!> Calculates the Eady growth rate (2D fields) for use in MEKE and the Visbeck schemes +subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, OBC, h, e, dzu, dzv, dzSxN, dzSyN, SN_u, SN_v) + type(VarMix_CS), intent(in) :: CS !< Variable mixing coefficients + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer, intent(in) :: OBC !< Open boundaries control structure. +real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Interface height [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface height [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzu !< dz at u-points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: dzv !< dz at v-points [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzSxN !< dz Sx N at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: dzSyN !< dz Sy N at v-points [Z T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: SN_u !< SN at u-points [T-1 ~> s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: SN_v !< SN at v-points [T-1 ~> s-1] + ! Local variables + real :: D_scale ! The depth over which to average SN [Z ~> m] + real :: dnew ! Depth of bottom of layer [Z ~> m] + real :: dz ! Limited thickness of this layer [Z ~> m] + real :: weight ! Fraction of this layer that contributes to integral [nondim] + real :: sum_dz(SZI_(G)) ! Cumulative sum of z-thicknesses [Z ~> m] + real :: vint_SN(SZIB_(G)) ! Cumulative integral of SN [Z T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G)) :: SN_cpy !< SN at u-points [T-1 ~> s-1] + real :: dz_neglect ! An incy wincy distance to avoid division by zero [Z ~> m] + real :: r_crp_dist ! The inverse of the distance over which to scale the cropping [Z-1 ~. m-1] + real :: dB, dT ! Elevation variables used when cropping [Z ~> m] + integer :: i, j, k, l_seg + logical :: local_open_u_BC, local_open_v_BC, crop + + dz_neglect = GV%H_subroundoff * GV%H_to_Z + D_scale = CS%Eady_GR_D_scale + if (D_scale<=0.) D_scale = 64.*GV%max_depth ! 0 means use full depth so choose something big + r_crp_dist = 1. / max( dz_neglect, CS%cropping_distance ) + crop = CS%cropping_distance>=0. ! Only filter out in-/out-cropped interface is parameter if non-negative + + local_open_u_BC = .false. + local_open_v_BC = .false. + if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif + + if (CS%debug) then + call uvchksum("calc_Eady_growth_rate_2D dz[uv]", dzu, dzv, G%HI, scale=US%Z_to_m, scalar_pair=.true.) + call uvchksum("calc_Eady_growth_rate_2D dzS2N2[uv]", dzSxN, dzSyN, G%HI, & + scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + endif + + !$OMP parallel do default(shared) + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%SN_u(i,j) = 0.0 + CS%SN_v(i,j) = 0.0 + enddo ; enddo + + !$OMP parallel do default(shared) private(dnew,dz,weight,l_seg,vint_SN,sum_dz) + do j = G%jsc-1,G%jec+1 + do I=G%isc-1,G%iec + vint_SN(I) = 0. + sum_dz(I) = dz_neglect + enddo + if (crop) then + do K=2,GV%ke ; do I=G%isc-1,G%iec + dnew = sum_dz(I) + dzu(I,j,K) ! This is where the bottom of the layer is + dnew = min(dnew, D_scale) ! This limits the depth to D_scale + dz = max(0., dnew - sum_dz(I)) ! This is the part of the layer to be included in the integral. + ! When D_scale>dnew, dz=dzu (+roundoff error). + ! When sum_dzdnew, dz=dzu (+roundoff error). + ! When sum_dzdnew, dz=dzu (+roundoff error). + ! When sum_dzdnew, dz=dzu (+roundoff error). + ! When sum_dz The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. @@ -980,7 +1183,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%calculate_cg1 = .false. CS%calculate_Rd_dx = .false. CS%calculate_res_fns = .false. - CS%calculate_Eady_growth_rate = .false. + CS%use_simpler_Eady_growth_rate = .false. CS%calculate_depth_fns = .false. ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -1042,7 +1245,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & default=.false., do_not_log=.true.) CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. use_MEKE - CS%calculate_Eady_growth_rate = CS%calculate_Eady_growth_rate .or. use_MEKE + ! Indicate whether to calculate the Eady growth rate + CS%calculate_Eady_growth_rate = use_MEKE & + .or. (KhTr_Slope_Cff>0.) & + .or. (KhTh_Slope_Cff>0.) call get_param(param_file, mdl, "KHTR_PASSIVITY_COEFF", KhTr_passivity_coeff, & default=0., do_not_log=.true.) CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. (KhTr_passivity_coeff>0.) @@ -1062,13 +1268,16 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke)) ; CS%ebt_struct(:,:,:) = 0.0 endif - if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then - CS%calculate_Eady_growth_rate = .true. - call get_param(param_file, mdl, "VISBECK_MAX_SLOPE", CS%Visbeck_S_max, & - "If non-zero, is an upper bound on slopes used in the "//& - "Visbeck formula for diffusivity. This does not affect the "//& - "isopycnal slope calculation used within thickness diffusion.", & - units="nondim", default=0.0) + if (CS%use_stored_slopes) then + if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then + call get_param(param_file, mdl, "VISBECK_MAX_SLOPE", CS%Visbeck_S_max, & + "If non-zero, is an upper bound on slopes used in the "//& + "Visbeck formula for diffusivity. This does not affect the "//& + "isopycnal slope calculation used within thickness diffusion.", & + units="nondim", default=0.0) + else + CS%Visbeck_S_max = 0. + endif endif if (CS%use_stored_slopes) then @@ -1089,10 +1298,27 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Inverse eddy time-scale, S*N, at u-points', 's-1', conversion=US%s_to_T) CS%id_SN_v = register_diag_field('ocean_model', 'SN_v', diag%axesCv1, Time, & 'Inverse eddy time-scale, S*N, at v-points', 's-1', conversion=US%s_to_T) - call get_param(param_file, mdl, "VARMIX_KTOP", CS%VarMix_Ktop, & - "The layer number at which to start vertical integration "//& - "of S*N for purposes of finding the Eady growth rate.", & - units="nondim", default=2) + call get_param(param_file, mdl, "USE_SIMPLER_EADY_GROWTH_RATE", CS%use_simpler_Eady_growth_rate, & + "If true, use a simpler method to calculate the Eady growth rate "//& + "that avoids division by layer thickness. Recommended.", default=.false.) + if (CS%use_simpler_Eady_growth_rate) then + if (.not. CS%use_stored_slopes) call MOM_error(FATAL, & + "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& + "When USE_SIMPLER_EADY_GROWTH_RATE=True, USE_STORED_SLOPES must also be True.") + call get_param(param_file, mdl, "EADY_GROWTH_RATE_D_SCALE", CS%Eady_GR_D_scale, & + "The depth from surface over which to average SN when calculating "//& + "a 2D Eady growth rate. Zero mean use full depth.", & + units="m", default=0., scale=US%m_to_Z) + call get_param(param_file, mdl, "EADY_GROWTH_RATE_CROPPING_DISTANCE", CS%cropping_distance, & + "Distance from surface or bottom to filter out outcropped or "//& + "incropped interfaces for the Eady growth rate calc. "//& + "Negative values disables cropping.", units="m", default=0., scale=US%m_to_Z) + else + call get_param(param_file, mdl, "VARMIX_KTOP", CS%VarMix_Ktop, & + "The layer number at which to start vertical integration "//& + "of S*N for purposes of finding the Eady growth rate.", & + units="nondim", default=2) + endif endif if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then @@ -1130,6 +1356,20 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Square of Brunt-Vaisala frequency, N^2, at v-points, as used in Visbeck et al.', & 's-2', conversion=(US%L_to_Z*US%s_to_T)**2) endif + if (CS%use_simpler_Eady_growth_rate) then + CS%id_dzu = register_diag_field('ocean_model', 'dzu_Visbeck', diag%axesCui, Time, & + 'dz at u-points, used in calculating Eady growth rate in Visbeck et al..', & + 'm', conversion=US%Z_to_m) + CS%id_dzv = register_diag_field('ocean_model', 'dzv_Visbeck', diag%axesCvi, Time, & + 'dz at v-points, used in calculating Eady growth rate in Visbeck et al..', & + 'm', conversion=US%Z_to_m) + CS%id_dzSxN = register_diag_field('ocean_model', 'dzSxN', diag%axesCui, Time, & + 'dz * |slope_x| * N, used in calculating Eady growth rate in '//& + 'Visbeck et al..', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_dzSyN = register_diag_field('ocean_model', 'dzSyN', diag%axesCvi, Time, & + 'dz * |slope_y| * N, used in calculating Eady growth rate in '//& + 'Visbeck et al..', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 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.', & @@ -1352,6 +1592,65 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) end subroutine VarMix_init +!> Destructor for VarMix control structure +subroutine VarMix_end(CS) + type(VarMix_CS), intent(inout) :: CS + + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct) & + deallocate(CS%ebt_struct) + + if (CS%use_stored_slopes) then + deallocate(CS%slope_x) + deallocate(CS%slope_y) + endif + + if (CS%calculate_Eady_growth_rate) then + deallocate(CS%SN_u) + deallocate(CS%SN_v) + endif + + if (associated(CS%L2u)) deallocate(CS%L2u) + if (associated(CS%L2v)) deallocate(CS%L2v) + + if (CS%Resoln_scaled_Kh .or. CS%Resoln_scaled_KhTh .or. CS%Resoln_scaled_KhTr) then + deallocate(CS%Res_fn_h) + deallocate(CS%Res_fn_q) + deallocate(CS%Res_fn_u) + deallocate(CS%Res_fn_v) + deallocate(CS%beta_dx2_q) + deallocate(CS%beta_dx2_u) + deallocate(CS%beta_dx2_v) + deallocate(CS%f2_dx2_q) + deallocate(CS%f2_dx2_u) + deallocate(CS%f2_dx2_v) + endif + + if (CS%Depth_scaled_KhTh) then + deallocate(CS%Depth_fn_u) + deallocate(CS%Depth_fn_v) + endif + + if (CS%calculate_Rd_dx) then + deallocate(CS%Rd_dx_h) + deallocate(CS%beta_dx2_h) + deallocate(CS%f2_dx2_h) + endif + + if (CS%calculate_cg1) then + deallocate(CS%cg1) + endif + + if (CS%Use_QG_Leith_GM) then + DEALLOC_(CS%Laplac3_const_u) + DEALLOC_(CS%Laplac3_const_v) + DEALLOC_(CS%KH_u_QG) + DEALLOC_(CS%KH_v_QG) + endif + + if (CS%calculate_cg1) deallocate(CS%wave_speed_CSp) + +end subroutine VarMix_end + !> \namespace mom_lateral_mixing_coeffs !! !! This module provides a container for various factors used in prescribing diffusivities, that are diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index b370332d90..9da72d9b2d 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -891,21 +891,21 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, flux_to_kg_per_s = GV%H_to_kg_m2 * US%L_to_m**2 * US%s_to_T CS%id_uhml = register_diag_field('ocean_model', 'uhml', diag%axesCuL, Time, & - 'Zonal Thickness Flux to Restratify Mixed Layer', 'kg s-1', & - conversion=flux_to_kg_per_s, y_cell_method='sum', v_extensive=.true.) + 'Zonal Thickness Flux to Restratify Mixed Layer', & + 'kg s-1', conversion=flux_to_kg_per_s, y_cell_method='sum', v_extensive=.true.) CS%id_vhml = register_diag_field('ocean_model', 'vhml', diag%axesCvL, Time, & - 'Meridional Thickness Flux to Restratify Mixed Layer', 'kg s-1', & - conversion=flux_to_kg_per_s, x_cell_method='sum', v_extensive=.true.) + 'Meridional Thickness Flux to Restratify Mixed Layer', & + 'kg s-1', conversion=flux_to_kg_per_s, x_cell_method='sum', v_extensive=.true.) CS%id_urestrat_time = register_diag_field('ocean_model', 'MLu_restrat_time', diag%axesCu1, Time, & 'Mixed Layer Zonal Restratification Timescale', 's', conversion=US%T_to_s) CS%id_vrestrat_time = register_diag_field('ocean_model', 'MLv_restrat_time', diag%axesCv1, Time, & 'Mixed Layer Meridional Restratification Timescale', 's', conversion=US%T_to_s) CS%id_MLD = register_diag_field('ocean_model', 'MLD_restrat', diag%axesT1, Time, & - 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', 'm', & - conversion=GV%H_to_m) + 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', & + 'm', conversion=GV%H_to_m) CS%id_Rml = register_diag_field('ocean_model', 'ML_buoy_restrat', diag%axesT1, Time, & 'Mixed Layer Buoyancy as used in the mixed-layer restratification parameterization', & - 'm s2', conversion=US%m_to_Z*(US%L_to_m**2)*(US%s_to_T**2)) + 'm s2', conversion=US%m_to_Z*(US%L_T_to_m_s**2)) CS%id_uDml = register_diag_field('ocean_model', 'udml_restrat', diag%axesCu1, Time, & 'Transport stream function amplitude for zonal restratification of mixed layer', & 'm3 s-1', conversion=GV%H_to_m*(US%L_to_m**2)*US%s_to_T) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 02a49a2a1a..da62ffc6b7 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -2116,10 +2116,23 @@ subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G, GV) end subroutine thickness_diffuse_get_KH !> Deallocate the thickness diffusion control structure -subroutine thickness_diffuse_end(CS) - type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion +subroutine thickness_diffuse_end(CS, CDp) + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion + type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity diagnostic control structure - if (associated(CS)) deallocate(CS) + if (CS%id_slope_x > 0) deallocate(CS%diagSlopeX) + if (CS%id_slope_y > 0) deallocate(CS%diagSlopeY) + + if (CS%id_GMwork > 0) deallocate(CS%GMwork) + + ! NOTE: [uv]hGM may be allocated either here or the diagnostic module + if (associated(CDp%uhGM)) deallocate(CDp%uhGM) + if (associated(CDp%vhGM)) deallocate(CDp%vhGM) + + if (CS%use_GME_thickness_diffuse) then + deallocate(CS%KH_u_GME) + deallocate(CS%KH_v_GME) + endif end subroutine thickness_diffuse_end !> \namespace mom_thickness_diffuse diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 1f95cb5162..307fbbe3ef 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -667,8 +667,8 @@ end subroutine calc_tidal_forcing !> This subroutine deallocates memory associated with the tidal forcing module. subroutine tidal_forcing_end(CS) - type(tidal_forcing_CS), pointer :: CS !< The control structure returned by a previous call - !! to tidal_forcing_init; it is deallocated here. + type(tidal_forcing_CS), intent(inout) :: CS !< The control structure returned by a previous call + !! to tidal_forcing_init; it is deallocated here. if (associated(CS%sin_struct)) deallocate(CS%sin_struct) if (associated(CS%cos_struct)) deallocate(CS%cos_struct) @@ -680,9 +680,6 @@ subroutine tidal_forcing_end(CS) if (associated(CS%cosphase_prev)) deallocate(CS%cosphase_prev) if (associated(CS%sinphase_prev)) deallocate(CS%sinphase_prev) if (associated(CS%amp_prev)) deallocate(CS%amp_prev) - - if (associated(CS)) deallocate(CS) - end subroutine tidal_forcing_end !> \namespace tidal_forcing diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index ce6dab906f..31d2ab5a76 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -167,12 +167,12 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure integer, intent(in) :: nz_data !< The total number of sponge input layers. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module (in/out). - real, dimension(SZI_(G),SZJ_(G),nz_data), intent(in) :: data_h !< The thicknesses of the sponge + real, dimension(SZI_(G),SZJ_(G),nz_data), intent(inout) :: data_h !< The thicknesses of the sponge !! input layers [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: Iresttime_u_in !< The inverse of the restoring !! time at U-points [T-1 ~> s-1]. @@ -287,6 +287,9 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)) ; Iresttime_u(:,:) = 0.0 allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)) ; Iresttime_v(:,:) = 0.0 + call pass_var(Iresttime,G%Domain) + call pass_var(data_h,G%Domain) + ! u points CS%num_col_u = 0 ; if (present(Iresttime_u_in)) then @@ -823,13 +826,21 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename ! get a unique id for this field which will allow us to return an array ! containing time-interpolated values from an external file corresponding ! to the current model date. - CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u, domain=G%Domain%mpp_domain) + if (CS%spongeDataOngrid) then + CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u, domain=G%Domain%mpp_domain) + else + CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u) + endif fld_sz(1:4)=-1 call get_external_field_info(CS%Ref_val_u%id, size=fld_sz) CS%Ref_val_u%nz_data = fld_sz(3) CS%Ref_val_u%num_tlevs = fld_sz(4) - CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v, domain=G%Domain%mpp_domain) + if (CS%spongeDataOngrid) then + CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v, domain=G%Domain%mpp_domain) + else + CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v) + endif fld_sz(1:4)=-1 call get_external_field_info(CS%Ref_val_v%id, size=fld_sz) CS%Ref_val_v%nz_data = fld_sz(3) @@ -872,6 +883,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real, allocatable, dimension(:,:,:) :: sp_val_u ! A temporary array for fields real, allocatable, dimension(:,:,:) :: sp_val_v ! A temporary array for fields real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts + real, allocatable, dimension(:,:,:) :: mask_u ! A temporary array for field mask at u pts + real, allocatable, dimension(:,:,:) :: mask_v ! A temporary array for field mask at v pts real, allocatable, dimension(:,:,:) :: tmp !< A temporary array for thermodynamic sponge tendency diagnostics, real, allocatable, dimension(:,:,:) :: tmp_u !< A temporary array for u sponge acceleration diagnostics real, allocatable, dimension(:,:,:) :: tmp_v !< A temporary array for v sponge acceleration diagnostics @@ -994,9 +1007,11 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) nz_data = CS%Ref_val_u%nz_data allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) allocate(sp_val_u(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) - allocate(mask_z(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) + allocate(mask_u(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) + allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) sp_val(:,:,:) = 0.0 sp_val_u(:,:,:) = 0.0 + mask_u(:,:,:) = 0.0 mask_z(:,:,:) = 0.0 ! Interpolate from the external horizontal grid and in time call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, 1.0, G, sp_val, mask_z, z_in, & @@ -1006,7 +1021,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) call pass_var(sp_val,G%Domain) do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB - sp_val_u(I,j,1:nz_data) = 0.5*(sp_val(i,j,1:nz_data)+sp_val(i+1,j,1:nz_data)) + sp_val_u(I,j,1:nz_data) = 0.5*(sp_val(i,j,1:nz_data)+sp_val(i+1,j,1:nz_data)) + mask_u(I,j,1:nz_data) = max(mask_z(i,j,1:nz_data),mask_z(i+1,j,1:nz_data)) enddo ; enddo allocate( hsrc(nz_data) ) @@ -1019,7 +1035,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! Build the source grid zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 do k=1,nz_data - if (mask_z(i,j,k) == 1.0) then + if (mask_u(i,j,k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(i,j) ) tmpT1d(k) = sp_val_u(i,j,k) elseif (k>1) then @@ -1030,17 +1046,18 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) endif hsrc(k) = zTopOfCell - zBottomOfCell if (hsrc(k)>0.) nPoints = nPoints + 1 - zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo ! In case data is deeper than model hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) CS%Ref_val_u%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) enddo - deallocate(sp_val, sp_val_u, mask_z, hsrc, tmpT1d) + deallocate(sp_val, sp_val_u, mask_u, mask_z, hsrc, tmpT1d) nz_data = CS%Ref_val_v%nz_data allocate(sp_val( G%isd:G%ied,G%jsd:G%jed,1:nz_data)) allocate(sp_val_v(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) - allocate(mask_z(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) + allocate(mask_v(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) + allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) sp_val(:,:,:) = 0.0 sp_val_v(:,:,:) = 0.0 mask_z(:,:,:) = 0.0 @@ -1052,6 +1069,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) call pass_var(sp_val,G%Domain) do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec sp_val_v(i,J,1:nz_data) = 0.5*(sp_val(i,j,1:nz_data)+sp_val(i,j+1,1:nz_data)) + mask_v(i,J,1:nz_data) = max(mask_z(i,j,1:nz_data),mask_z(i,j+1,1:nz_data)) enddo ; enddo !call pass_var(mask_z,G%Domain) allocate( hsrc(nz_data) ) @@ -1064,7 +1082,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! Build the source grid zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 do k=1,nz_data - if (mask_z(i,j,k) == 1.0) then + if (mask_v(i,j,k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(i,j) ) tmpT1d(k) = sp_val_v(i,j,k) elseif (k>1) then @@ -1081,9 +1099,10 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) CS%Ref_val_v%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) enddo - deallocate(sp_val, sp_val_v, mask_z, hsrc, tmpT1d) + deallocate(sp_val, sp_val_v, mask_v, mask_z, hsrc, tmpT1d) endif + call pass_var(h,G%Domain) nz_data = CS%Ref_val_u%nz_data allocate(tmp_val2(nz_data)) if (CS%id_sp_u_tendency > 0) then @@ -1282,7 +1301,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) endif enddo - ! TODO: var_u and var_v sponge dampling is not yet supported. + ! TODO: var_u and var_v sponge damping is not yet supported. if (associated(sponge_in%var_u%p) .or. associated(sponge_in%var_v%p)) & call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet " & // "implemented.") diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 0dfa29931d..083f5ed000 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1056,8 +1056,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl surfHu = surfHu + 0.5*US%L_T_to_m_s*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH surfHv = surfHv + 0.5*US%L_T_to_m_s*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH if (CS%Stokes_Mixing) then - surfHus = surfHus + 0.5*(WAVES%US_x(i,j,ktmp)+WAVES%US_x(i-1,j,ktmp)) * delH - surfHvs = surfHvs + 0.5*(WAVES%US_y(i,j,ktmp)+WAVES%US_y(i,j-1,ktmp)) * delH + surfHus = surfHus + 0.5*US%L_T_to_m_s*(WAVES%US_x(i,j,ktmp)+WAVES%US_x(i-1,j,ktmp)) * delH + surfHvs = surfHvs + 0.5*US%L_T_to_m_s*(WAVES%US_y(i,j,ktmp)+WAVES%US_y(i,j-1,ktmp)) * delH endif enddo @@ -1078,8 +1078,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! If momentum is mixed down the Stokes drift gradient, then ! the Stokes drift must be included in the bulk Richardson number ! calculation. - Uk = Uk + (0.5*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) -surfUs ) - Vk = Vk + (0.5*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) -surfVs ) + Uk = Uk + (0.5*US%L_T_to_m_s*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) - surfUs ) + Vk = Vk + (0.5*US%L_T_to_m_s*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) - surfVs ) endif deltaU2(k) = Uk**2 + Vk**2 diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 89c0bf8377..8b007a0b11 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -68,7 +68,6 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) "control structure.") return endif - allocate(CS) ! Read parameters call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_init, default=.false., do_not_log=.true.) @@ -83,6 +82,7 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) default=.false.) if (.not. CVMix_conv_init) return + allocate(CS) call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", useEPBL, default=.false., & do_not_log=.true.) @@ -310,14 +310,10 @@ logical function CVMix_conv_is_used(param_file) end function CVMix_conv_is_used !> Clear pointers and dealocate memory +! NOTE: Placeholder destructor subroutine CVMix_conv_end(CS) type(CVMix_conv_cs), pointer :: CS !< Control structure for this module that !! will be deallocated in this subroutine - - if (.not. associated(CS)) return - - deallocate(CS) - end subroutine CVMix_conv_end end module MOM_CVMix_conv diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index e487e616af..f1ac4c926a 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -65,7 +65,6 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) "control structure.") return endif - allocate(CS) ! Read parameters call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, default=.false., do_not_log=.true.) @@ -79,6 +78,7 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) default=.false.) if (.not. CVMix_ddiff_init) return + allocate(CS) call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) @@ -279,12 +279,10 @@ logical function CVMix_ddiff_is_used(param_file) end function CVMix_ddiff_is_used !> Clear pointers and dealocate memory +! NOTE: Placeholder destructor subroutine CVMix_ddiff_end(CS) type(CVMix_ddiff_cs), pointer :: CS !< Control structure for this module that !! will be deallocated in this subroutine - - deallocate(CS) - end subroutine CVMix_ddiff_end end module MOM_CVMix_ddiff diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 85d9c63a39..35e5352a9f 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -211,6 +211,9 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) ! Local variables integer :: NumberTrue=0 logical :: use_JHL + logical :: use_LMD94 + logical :: use_PP81 + ! This include declares and sets the variable "version". #include "version_variable.h" @@ -219,28 +222,23 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) "control structure.") return endif - allocate(CS) ! Set default, read and log parameters - call get_param(param_file, mdl, "USE_LMD94", CS%use_LMD94, default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "USE_PP81", CS%use_PP81, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_LMD94", use_LMD94, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_PP81", use_PP81, default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & "Parameterization of shear-driven turbulence via CVMix (various options)", & - all_default=.not.(CS%use_PP81.or.CS%use_LMD94)) - call get_param(param_file, mdl, "USE_LMD94", CS%use_LMD94, & + all_default=.not.(use_PP81.or.use_LMD94)) + call get_param(param_file, mdl, "USE_LMD94", use_LMD94, & "If true, use the Large-McWilliams-Doney (JGR 1994) "//& "shear mixing parameterization.", default=.false.) - if (CS%use_LMD94) then + if (use_LMD94) & NumberTrue=NumberTrue + 1 - CS%Mix_Scheme='KPP' - endif - call get_param(param_file, mdl, "USE_PP81", CS%use_PP81, & + call get_param(param_file, mdl, "USE_PP81", use_PP81, & "If true, use the Pacanowski and Philander (JPO 1981) "//& "shear mixing parameterization.", default=.false.) - if (CS%use_PP81) then + if (use_PP81) & NumberTrue = NumberTrue + 1 - CS%Mix_Scheme='PP' - endif use_JHL=kappa_shear_is_used(param_file) if (use_JHL) NumberTrue = NumberTrue + 1 ! After testing for interior schemes, make sure only 0 or 1 are enabled. @@ -250,10 +248,20 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) 'Multiple shear driven internal mixing schemes selected,'//& ' please disable all but one scheme to proceed.') endif - CVMix_shear_init=(CS%use_PP81.or.CS%use_LMD94) -! Forego remainder of initialization if not using this scheme + CVMix_shear_init = use_PP81 .or. use_LMD94 + + ! Forego remainder of initialization if not using this scheme if (.not. CVMix_shear_init) return + + allocate(CS) + CS%use_LMD94 = use_LMD94 + CS%use_PP81 = use_PP81 + if (use_LMD94) & + CS%Mix_Scheme = 'KPP' + if (use_PP81) & + CS%Mix_Scheme = 'PP' + call get_param(param_file, mdl, "NU_ZERO", CS%Nu_Zero, & "Leading coefficient in KPP shear mixing.", & units="nondim", default=5.e-3) @@ -326,16 +334,11 @@ end function CVMix_shear_is_used !> Clear pointers and dealocate memory subroutine CVMix_shear_end(CS) - type(CVMix_shear_cs), pointer :: CS !< Control structure for this module that - !! will be deallocated in this subroutine - - if (.not. associated(CS)) return - + type(CVMix_shear_cs), intent(inout) :: CS !< Control structure for this module that + !! will be deallocated in this subroutine if (CS%id_N2 > 0) deallocate(CS%N2) if (CS%id_S2 > 0) deallocate(CS%S2) if (CS%id_ri_grad > 0) deallocate(CS%ri_grad) - deallocate(CS) - end subroutine CVMix_shear_end end module MOM_CVMix_shear diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 83d817c0d2..a09d629239 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -235,7 +235,7 @@ module MOM_diabatic_driver type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() !< Control structure for a child module type(optics_type), pointer :: optics => NULL() !< Control structure for a child module type(KPP_CS), pointer :: KPP_CSp => NULL() !< Control structure for a child module - type(CVMix_conv_cs), pointer :: CVMix_conv_csp => NULL() !< Control structure for a child module + type(CVMix_conv_cs), pointer :: CVMix_conv_CSp => NULL() !< Control structure for a child module type(diapyc_energy_req_CS), pointer :: diapyc_en_rec_CSp => NULL() !< Control structure for a child module type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() !< Control structure for a child module @@ -763,7 +763,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! Calculate vertical mixing due to convection (computed via CVMix) if (CS%use_CVMix_conv) then ! Increment vertical diffusion and viscosity due to convection - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_csp, Hml, Kd=Kd_int, Kv=visc%Kv_slow) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_CSp, Hml, Kd=Kd_int, Kv=visc%Kv_slow) endif ! This block sets ent_t and ent_s from h and Kd_int. @@ -1309,9 +1309,9 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%use_CVMix_conv) then ! Increment vertical diffusion and viscosity due to convection if (CS%useKPP) then - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_csp, Hml, Kd=Kd_heat, Kv=visc%Kv_shear, Kd_aux=Kd_salt) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_CSp, Hml, Kd=Kd_heat, Kv=visc%Kv_shear, Kd_aux=Kd_salt) else - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_csp, Hml, Kd=Kd_heat, Kv=visc%Kv_slow, Kd_aux=Kd_salt) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_CSp, Hml, Kd=Kd_heat, Kv=visc%Kv_slow, Kd_aux=Kd_salt) endif endif @@ -1891,7 +1891,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Add vertical diff./visc. due to convection (computed via CVMix) if (CS%use_CVMix_conv) then - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_csp, Hml, Kd=Kd_int, Kv=visc%Kv_slow) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_CSp, Hml, Kd=Kd_int, Kv=visc%Kv_slow) endif if (CS%useKPP) then @@ -2372,7 +2372,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) do j=js,je do K=2,nz ; do i=is,ie - CDp%diapyc_vel(i,j,K) = US%s_to_T*Idt * (ea(i,j,k) - eb(i,j,k-1)) + CDp%diapyc_vel(i,j,K) = Idt * (ea(i,j,k) - eb(i,j,k-1)) enddo ; enddo do i=is,ie CDp%diapyc_vel(i,j,1) = 0.0 @@ -3071,7 +3071,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Layer entrainment from below per timestep', 'm', conversion=GV%H_to_m) if (.not.CS%useALEalgorithm) then CS%id_wd = register_diag_field('ocean_model', 'wd', diag%axesTi, Time, & - 'Diapycnal velocity', 'm s-1', conversion=GV%H_to_m) + 'Diapycnal velocity', 'm s-1', conversion=GV%H_to_m*US%s_to_T) if (CS%id_wd > 0) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) CS%id_dudt_dia = register_diag_field('ocean_model', 'dudt_dia', diag%axesCuL, Time, & @@ -3189,8 +3189,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Salinity', 'PSU') endif - - !call set_diffusivity_init(Time, G, param_file, diag, CS%set_diff_CSp, CS%int_tide_CSp) CS%id_Kd_int = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s) if (CS%use_energetic_PBL) then @@ -3304,8 +3302,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di units='m', conversion=GV%H_to_m, v_extensive=.true.) CS%id_boundary_forcing_h_tendency = register_diag_field('ocean_model', & 'boundary_forcing_h_tendency', diag%axesTL, Time, & - 'Cell thickness tendency due to boundary forcing', 'm s-1', & - conversion=GV%H_to_m*US%s_to_T, v_extensive=.true.) + 'Cell thickness tendency due to boundary forcing', & + 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive=.true.) if (CS%id_boundary_forcing_h_tendency > 0) then CS%boundary_forcing_tendency_diag = .true. endif @@ -3391,7 +3389,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif ! CS%use_CVMix_conv is set to True if CVMix convection will be used, otherwise it is False. - CS%use_CVMix_conv = CVMix_conv_init(Time, G, GV, US, param_file, diag, CS%CVMix_conv_csp) + CS%use_CVMix_conv = CVMix_conv_init(Time, G, GV, US, param_file, diag, CS%CVMix_conv_CSp) call entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS%entrain_diffusive_CSp, & just_read_params=CS%useALEalgorithm) @@ -3466,15 +3464,36 @@ end subroutine diabatic_driver_init !> Routine to close the diabatic driver module subroutine diabatic_driver_end(CS) - type(diabatic_CS), pointer :: CS !< module control structure + type(diabatic_CS), intent(inout) :: CS !< module control structure + + if (associated(CS%optics)) then + call opacity_end(CS%opacity_CSp, CS%optics) + deallocate(CS%optics) + endif + + if (CS%debug_energy_req) & + call diapyc_energy_req_end(CS%diapyc_en_rec_CSp) - if (.not.associated(CS)) return + deallocate(CS%regularize_layers_CSp) + + if (CS%use_energetic_PBL) & + call energetic_PBL_end(CS%energetic_PBL_CSp) call diabatic_aux_end(CS%diabatic_aux_CSp) - call entrain_diffusive_end(CS%entrain_diffusive_CSp) call set_diffusivity_end(CS%set_diff_CSp) + deallocate(CS%set_diff_CSp) + + if (CS%use_geothermal) then + call geothermal_end(CS%geothermal_CSp) + deallocate(CS%geothermal_CSp) + endif + + call entrain_diffusive_end(CS%entrain_diffusive_CSp) + + if (CS%use_CVMix_conv) deallocate(CS%CVMix_conv_CSp) + if (CS%useKPP) then deallocate( CS%KPP_buoy_flux ) deallocate( CS%KPP_temp_flux ) @@ -3484,26 +3503,11 @@ subroutine diabatic_driver_end(CS) call KPP_end(CS%KPP_CSp) endif - if (CS%use_CVMix_conv) call CVMix_conv_end(CS%CVMix_conv_csp) - - if (CS%use_energetic_PBL) & - call energetic_PBL_end(CS%energetic_PBL_CSp) - if (CS%debug_energy_req) & - call diapyc_energy_req_end(CS%diapyc_en_rec_CSp) - - if (associated(CS%optics)) then - call opacity_end(CS%opacity_CSp, CS%optics) - deallocate(CS%optics) - endif - ! GMM, the following is commented out because arrays in ! CS%diag_grids_prev are neither pointers or allocatables ! and, therefore, cannot be deallocated. !call diag_grid_storage_end(CS%diag_grids_prev) - - deallocate(CS) - end subroutine diabatic_driver_end diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 0515f81725..23a73cb43e 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -1315,7 +1315,7 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) CS%id_Kddt = register_diag_field('ocean_model', 'EnReqTest_Kddt', diag%axesZi, Time, & "Implicit diffusive coupling coefficient", "m", conversion=GV%H_to_m) CS%id_Kd = register_diag_field('ocean_model', 'EnReqTest_Kd', diag%axesZi, Time, & - "Diffusivity in test", "m2 s-1", conversion=US%Z_to_m**2) + "Diffusivity in test", "m2 s-1", conversion=US%Z2_T_to_m2_s) CS%id_h = register_diag_field('ocean_model', 'EnReqTest_h_lay', diag%axesZL, Time, & "Test column layer thicknesses", "m", conversion=GV%H_to_m) CS%id_zInt = register_diag_field('ocean_model', 'EnReqTest_z_int', diag%axesZi, Time, & diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index a558f9dd2b..32cdce4d2a 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -352,7 +352,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! what maxF(kb+1) should be. do i=is,ie ; min_eakb(i) = MIN(htot(i), max_eakb(i)) ; enddo call find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_eakb, max_eakb, & - kmb, is, ie, G, GV, CS, F_kb_maxEnt, do_i_in = do_i) + kmb, is, ie, G, GV, CS, F_kb_maxEnt, do_i_in=do_i) do i=is,ie do_entrain_eakb = .false. @@ -891,7 +891,7 @@ end subroutine entrainment_diffusive !> This subroutine calculates the actual entrainments (ea and eb) and the !! amount of surface forcing that is applied to each layer if there is no bulk !! mixed layer. -subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, do_i_in) +subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZK_(GV)), intent(in) :: F !< The density flux through a layer within @@ -920,31 +920,13 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: eb !< The amount of fluid entrained from the layer !! below within this time step [H ~> m or kg m-2]. - logical, dimension(SZI_(G)), & - optional, intent(in) :: do_i_in !< Indicates which i-points to work on. -! This subroutine calculates the actual entrainments (ea and eb) and the -! amount of surface forcing that is applied to each layer if there is no bulk -! mixed layer. real :: h1 ! The thickness in excess of the minimum that will remain ! after exchange with the layer below [H ~> m or kg m-2]. - logical :: do_i(SZI_(G)) integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = GV%ke - if (present(do_i_in)) then - do i=is,ie ; do_i(i) = do_i_in(i) ; enddo - do i=G%isc,G%iec ; if (do_i(i)) then - is = i ; exit - endif ; enddo - do i=G%iec,G%isc,-1 ; if (do_i(i)) then - ie = i ; exit - endif ; enddo - else - do i=is,ie ; do_i(i) = .true. ; enddo - endif - do i=is,ie ea(i,j,nz) = 0.0 ; eb(i,j,nz) = 0.0 enddo @@ -952,7 +934,7 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, do i=is,ie eb(i,j,kmb) = max(2.0*Ent_bl(i,Kmb+1) - eakb(i), 0.0) enddo - do k=nz-1,kmb+1,-1 ; do i=is,ie ; if (do_i(i)) then + do k=nz-1,kmb+1,-1 ; do i=is,ie if (k > kb(i)) then ! With a bulk mixed layer, surface buoyancy fluxes are applied ! elsewhere, so F should always be nonnegative. @@ -970,9 +952,9 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ! up into the buffer layer. eb(i,j,k) = eb(i,j,k+1) + max(0.0, h(i,j,k+1) - GV%Angstrom_H) endif - endif ; enddo ; enddo + enddo ; enddo k = kmb - do i=is,ie ; if (do_i(i)) then + do i=is,ie ! Adjust the previously calculated entrainment from below by the deepest ! buffer layer to account for entrainment of thin interior layers . if (kb(i) > kmb+1) & @@ -981,8 +963,8 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ! Determine the entrainment from above for each buffer layer. h1 = (h(i,j,k) - GV%Angstrom_H) + (eb(i,j,k) - ea(i,j,k+1)) ea(i,j,k) = MAX(Ent_bl(i,K), Ent_bl(i,K)-0.5*h1, -h1) - endif ; enddo - do k=kmb-1,2,-1 ; do i=is,ie ; if (do_i(i)) then + enddo + do k=kmb-1,2,-1 ; do i=is,ie ! Determine the entrainment from below for each buffer layer. eb(i,j,k) = max(2.0*Ent_bl(i,K+1) - ea(i,j,k+1), 0.0) @@ -992,11 +974,11 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ! if (h1 >= 0.0) then ; ea(i,j,k) = Ent_bl(i,K) ! elseif (Ent_bl(i,K)+0.5*h1 >= 0.0) then ; ea(i,j,k) = Ent_bl(i,K)-0.5*h1 ! else ; ea(i,j,k) = -h1 ; endif - endif ; enddo ; enddo - do i=is,ie ; if (do_i(i)) then + enddo ; enddo + do i=is,ie eb(i,j,1) = max(2.0*Ent_bl(i,2) - ea(i,j,2), 0.0) ea(i,j,1) = 0.0 - endif ; enddo + enddo else ! not BULKMIXEDLAYER ! Calculate the entrainment by each layer from above and below. ! Entrainment is always positive, but F may be negative due to @@ -1511,7 +1493,7 @@ subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & ! the maximum. zeros(i) = 0.0 call find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, zeros, ea_kb, & - kmb, i, i, G, GV, CS, maxF, ent_maxF, F_thresh = F_kb) + kmb, i, i, G, GV, CS, maxF, ent_maxF, F_thresh=F_kb) err_max = dS_kbp1 * maxF(i) - val ! If err_max is negative, there is no good solution, so use the maximum ! value of F in the valid range. @@ -1693,7 +1675,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & do_any = .false. ; do i=is,ie ; if (redo_i(i)) do_any = .true. ; enddo if (.not.do_any) exit call determine_dSkb(h_bl, Sref, Ent_bl, Ent, is, ie, kmb, G, GV, .true., dS_kb, & - ddSkb_dE, dS_lay, ddSlay_dE, do_i_in = redo_i) + ddSkb_dE, dS_lay, ddSlay_dE, do_i_in=redo_i) do i=is,ie ; if (redo_i(i)) then ! The correct root is bracketed between E_min and E_max. ! Note the following limits: Ent >= 0 ; fa > 1 ; fk > 0 @@ -1757,7 +1739,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & ! Update the value of dS_kb for consistency with Ent. if (present(F_kb) .or. present(dFdfm_kb)) & call determine_dSkb(h_bl, Sref, Ent_bl, Ent, is, ie, kmb, G, GV, .true., & - dS_kb, do_i_in = do_i) + dS_kb, do_i_in=do_i) if (present(F_kb)) then ; do i=is,ie ; if (do_i(i)) then F_kb(i) = Ent(i) * (dS_kb(i) * I_dSkbp1(i)) @@ -1878,7 +1860,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & do i=ie1,is,-1 ; if (do_i(i)) is1 = i ; enddo ! Find the value of F and its derivative at min_ent. call determine_dSkb(h_bl, Sref, Ent_bl, minent, is1, ie1, kmb, G, GV, .false., & - dS_kb, ddSkb_dE, do_i_in = do_i) + dS_kb, ddSkb_dE, do_i_in=do_i) do i=is1,ie1 ; if (do_i(i)) then F_minent(i) = minent(i) * dS_kb(i) * I_dSkbp1(i) dF_dE_min(i) = (dS_kb(i) + minent(i)*ddSkb_dE(i)) * I_dSkbp1(i) @@ -1958,7 +1940,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & endif call determine_dSkb(h_bl, Sref, Ent_bl, ent, is1, ie1, kmb, G, GV, .false., & - dS_kb, ddSkb_dE, do_i_in = do_i) + dS_kb, ddSkb_dE, do_i_in=do_i) do i=is1,ie1 ; if (do_i(i)) then F(i) = ent(i)*dS_kb(i)*I_dSkbp1(i) dF_dent(i) = (dS_kb(i) + ent(i)*ddSkb_dE(i)) * I_dSkbp1(i) @@ -2050,8 +2032,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & enddo if (doany) then ! For efficiency, could save previous value of dS_anom_lim_best? - call determine_dSkb(h_bl, Sref, Ent_bl, ent_best, is, ie, kmb, G, GV, .true., & - dS_kb_lim) + call determine_dSkb(h_bl, Sref, Ent_bl, ent_best, is, ie, kmb, G, GV, .true., dS_kb_lim) do i=is,ie F_best(i) = ent_best(i)*dS_kb_lim(i)*I_dSkbp1(i) ! The second test seems necessary because of roundoff differences that @@ -2088,14 +2069,13 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re !! output. type(entrain_diffusive_CS), pointer :: CS !< A pointer that is set to point to the control !! structure. - logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters logging them or registering + logical, intent(in) :: just_read_params !< If true, this call will only read + !! and log parameters without registering !! any diagnostics ! Local variables real :: dt ! The dynamics timestep, used here in the default for TOLERANCE_ENT, in MKS units [s] real :: Kd ! A diffusivity used in the default for TOLERANCE_ENT, in MKS units [m2 s-1] - logical :: just_read ! If true, just read parameters but do nothing else. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_entrain_diffusive" ! This module's name. @@ -2107,30 +2087,28 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re endif allocate(CS) - just_read = .false. ; if (present(just_read_params)) just_read = just_read_params - CS%diag => diag CS%bulkmixedlayer = (GV%nkml > 0) -! Set default, read and log parameters - if (.not.just_read) call log_version(param_file, mdl, version, "") + ! Set default, read and log parameters + if (.not.just_read_params) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & "The maximum number of iterations that may be used to "//& - "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read) + "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read_params) ! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] call get_param(param_file, mdl, "KD", Kd, default=0.0) call get_param(param_file, mdl, "DT", dt, & "The (baroclinic) dynamics time step.", units = "s", & - fail_if_missing=.true., do_not_log=just_read) + fail_if_missing=.true., do_not_log=just_read_params) call get_param(param_file, mdl, "TOLERANCE_ENT", CS%Tolerance_Ent, & "The tolerance with which to solve for entrainment values.", & units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, & - do_not_log=just_read) + do_not_log=just_read_params) CS%Rho_sig_off = 1000.0*US%kg_m3_to_R - if (.not.just_read) then + if (.not.just_read_params) then CS%id_Kd = register_diag_field('ocean_model', 'Kd_effective', diag%axesTL, Time, & 'Diapycnal diffusivity as applied', 'm2 s-1', conversion=US%Z2_T_to_m2_s) CS%id_diff_work = register_diag_field('ocean_model', 'diff_work', diag%axesTi, Time, & @@ -2138,7 +2116,7 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re 'W m-2', conversion=US%RZ3_T3_to_W_m2) endif - if (just_read) deallocate(CS) + if (just_read_params) deallocate(CS) end subroutine entrain_diffusive_init diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index be390ef50f..2195363101 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -592,18 +592,16 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS, useALEalgorith CS%id_internal_heat_h_tendency=register_diag_field('ocean_model', & 'internal_heat_h_tendency', diag%axesTL, Time, & 'Thickness tendency (in 3D) due to internal (geothermal) sources', & - trim(thickness_units), conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) + trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) endif ; endif end subroutine geothermal_init !> Clean up and deallocate memory associated with the geothermal heating module. subroutine geothermal_end(CS) - type(geothermal_CS), pointer :: CS !< Geothermal heating control structure that - !! will be deallocated in this subroutine. - - if (associated(CS%geo_heat)) deallocate(CS%geo_heat) - if (associated(CS)) deallocate(CS) + type(geothermal_CS), intent(inout) :: CS !< Geothermal heating control structure that + !! will be deallocated in this subroutine. + deallocate(CS%geo_heat) end subroutine geothermal_end !> \namespace mom_geothermal diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 7aca829db6..a1fe88d114 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -352,7 +352,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) units="m-1", default=8.e-4*atan(1.0), scale=US%L_to_m) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & - "A scaling factor for the roughness amplitude with n"//& + "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & "The maximum internal tide energy source available to mix "//& @@ -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_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 83d70c7ae3..0b6a3cf76c 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -1123,8 +1123,12 @@ subroutine opacity_end(CS, optics) if (associated(CS)) deallocate(CS) if (present(optics)) then ; if (associated(optics)) then - if (associated(optics%opacity_band)) deallocate(optics%opacity_band) if (associated(optics%sw_pen_band)) deallocate(optics%sw_pen_band) + if (associated(optics%opacity_band)) deallocate(optics%opacity_band) + if (associated(optics%max_wavelength_band)) & + deallocate(optics%max_wavelength_band) + if (associated(optics%min_wavelength_band)) & + deallocate(optics%min_wavelength_band) endif ; endif end subroutine opacity_end diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 0cb39b2f15..f4874252f4 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -355,7 +355,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif ! set up arrays for tidal mixing diagnostics - call setup_tidal_diagnostics(G, GV, CS%tidal_mixing_CSp) + if (CS%use_tidal_mixing) & + call setup_tidal_diagnostics(G, GV, CS%tidal_mixing_CSp) if (CS%useKappaShear) then if (CS%debug) then @@ -666,7 +667,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%id_Kv_bkgnd > 0) call post_data(CS%id_Kv_bkgnd, dd%Kv_bkgnd, CS%diag) ! tidal mixing - call post_tidal_diagnostics(G, GV, h, CS%tidal_mixing_CSp) + if (CS%use_tidal_mixing) & + call post_tidal_diagnostics(G, GV, h, CS%tidal_mixing_CSp) + if (CS%id_N2 > 0) call post_data(CS%id_N2, dd%N2_3d, CS%diag) if (CS%id_Kd_Work > 0) call post_data(CS%id_Kd_Work, dd%Kd_Work, CS%diag) if (CS%id_maxTKE > 0) call post_data(CS%id_maxTKE, dd%maxTKE, CS%diag) @@ -694,6 +697,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (associated(dd%KS_extra)) deallocate(dd%KS_extra) if (associated(dd%drho_rat)) deallocate(dd%drho_rat) if (associated(dd%Kd_BBL)) deallocate(dd%Kd_BBL) + if (associated(dd%Kd_bkgnd)) deallocate(dd%Kd_bkgnd) + if (associated(dd%Kv_bkgnd)) deallocate(dd%Kv_bkgnd) if (showCallTree) call callTree_leave("set_diffusivity()") @@ -2345,22 +2350,26 @@ end subroutine set_diffusivity_init !> Clear pointers and dealocate memory subroutine set_diffusivity_end(CS) - type(set_diffusivity_CS), pointer :: CS !< Control structure for this module - - if (.not.associated(CS)) return + type(set_diffusivity_CS), intent(inout) :: CS !< Control structure for this module call bkgnd_mixing_end(CS%bkgnd_mixing_csp) - if (CS%use_tidal_mixing) call tidal_mixing_end(CS%tidal_mixing_CSp) + if (CS%use_tidal_mixing) then + call tidal_mixing_end(CS%tidal_mixing_CSp) + deallocate(CS%tidal_mixing_CSp) + endif if (CS%user_change_diff) call user_change_diff_end(CS%user_change_diff_CSp) - if (CS%use_CVMix_shear) call CVMix_shear_end(CS%CVMix_shear_csp) - - if (CS%use_CVMix_ddiff) call CVMix_ddiff_end(CS%CVMix_ddiff_csp) + if (associated(CS%CVMix_ddiff_CSp)) deallocate(CS%CVMix_ddiff_CSp) - if (associated(CS)) deallocate(CS) + if (CS%use_CVMix_shear) then + call CVMix_shear_end(CS%CVMix_shear_CSp) + deallocate(CS%CVMix_shear_CSp) + endif + ! NOTE: CS%kappaShear_CSp is always allocated, even if unused + deallocate(CS%kappaShear_CSp) end subroutine set_diffusivity_end end module MOM_set_diffusivity 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 512179445b..21562817c0 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -219,6 +219,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) type(tidal_mixing_cs), pointer :: CS !< This module's control structure. ! Local variables + logical :: use_CVMix_tidal + logical :: int_tide_dissipation logical :: read_tideamp logical :: default_2018_answers character(len=20) :: tmpstr, int_tide_profile_str @@ -229,6 +231,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) real :: Niku_scale ! local variable for scaling the Nikurashin TKE flux data integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed + ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tidal_mixing" !< This module's name. @@ -238,39 +241,43 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) "is already associated.") return endif - allocate(CS) - allocate(CS%dd) - - CS%debug = CS%debug.and.is_root_pe() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - CS%diag => diag - ! Read parameters - call get_param(param_file, mdl, "USE_CVMix_TIDAL", CS%use_CVMix_tidal, & + ! NOTE: These are read twice because logfile output is streamed and we want + ! to preserve the ordering of module header before parameters. + call get_param(param_file, mdl, "USE_CVMix_TIDAL", use_CVMix_tidal, & default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", CS%int_tide_dissipation, & - default=CS%use_CVMix_tidal, do_not_log=.true.) + call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", int_tide_dissipation, & + default=use_CVMix_tidal, do_not_log=.true.) call log_version(param_file, mdl, version, & "Vertical Tidal Mixing Parameterization", & - all_default=.not.(CS%use_CVMix_tidal .or. CS%int_tide_dissipation)) - call get_param(param_file, mdl, "USE_CVMix_TIDAL", CS%use_CVMix_tidal, & + all_default=.not.(use_CVMix_tidal .or. int_tide_dissipation)) + + call get_param(param_file, mdl, "USE_CVMix_TIDAL", use_CVMix_tidal, & "If true, turns on tidal mixing via CVMix", & default=.false.) - - call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".",do_not_log=.true.) - CS%inputdir = slasher(CS%inputdir) - call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", CS%int_tide_dissipation, & + call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", int_tide_dissipation, & "If true, use an internal tidal dissipation scheme to "//& "drive diapycnal mixing, along the lines of St. Laurent "//& - "et al. (2002) and Simmons et al. (2004).", default=CS%use_CVMix_tidal) + "et al. (2002) and Simmons et al. (2004).", default=use_CVMix_tidal) ! return if tidal mixing is inactive - tidal_mixing_init = CS%int_tide_dissipation + tidal_mixing_init = int_tide_dissipation if (.not. tidal_mixing_init) return + allocate(CS) + allocate(CS%dd) + CS%debug = CS%debug.and.is_root_pe() + CS%diag => diag + CS%use_CVmix_tidal = use_CVmix_tidal + CS%int_tide_dissipation = int_tide_dissipation + + call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".",do_not_log=.true.) + CS%inputdir = slasher(CS%inputdir) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.false.) @@ -460,7 +467,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 +476,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, "//& @@ -1720,18 +1727,14 @@ end subroutine read_tidal_constituents !> Clear pointers and deallocate memory subroutine tidal_mixing_end(CS) - type(tidal_mixing_cs), pointer :: CS !< This module's control structure, which - !! will be deallocated in this routine. + type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure, which + !! will be deallocated in this routine. - if (.not.associated(CS)) return - - !TODO deallocate all the dynamically allocated members here ... + ! TODO: deallocate all the dynamically allocated members here ... if (allocated(CS%tidal_qe_2d)) deallocate(CS%tidal_qe_2d) if (allocated(CS%tidal_qe_3d_in)) deallocate(CS%tidal_qe_3d_in) if (allocated(CS%h_src)) deallocate(CS%h_src) deallocate(CS%dd) - deallocate(CS) - end subroutine tidal_mixing_end end module MOM_tidal_mixing diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index c7c9355f97..5b85c5f5f6 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -125,6 +125,7 @@ module MOM_vert_friction integer :: id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 + integer :: id_h_du_dt_visc = -1, id_h_dv_dt_visc = -1 integer :: id_hf_du_dt_visc_2d = -1, id_hf_dv_dt_visc_2d = -1 !>@} @@ -213,6 +214,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real, allocatable, dimension(:,:) :: hf_du_dt_visc_2d ! Depth sum of hf_du_dt_visc [L T-2 ~> m s-2] real, allocatable, dimension(:,:) :: hf_dv_dt_visc_2d ! Depth sum of hf_dv_dt_visc [L T-2 ~> m s-2] + real, allocatable, dimension(:,:,:) :: h_du_dt_visc ! h x du_dt_visc [H L T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_dv_dt_visc ! h x dv_dt_visc [H L T-2 ~> m2 s-2] + logical :: do_i(SZIB_(G)) logical :: DoStokesMixing @@ -254,7 +258,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) u(I,j,k) = u(I,j,k) + US%m_s_to_L_T*Waves%Us_x(I,j,k) + if (do_i(I)) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) enddo ; enddo ; endif if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq @@ -347,7 +351,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! When mixing down Eulerian current + Stokes drift subtract after calling solver if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) u(I,j,k) = u(I,j,k) - US%m_s_to_L_T*Waves%Us_x(I,j,k) + if (do_i(I)) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) enddo ; enddo ; endif enddo ! end u-component j loop @@ -362,7 +366,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie - if (do_i(i)) v(i,j,k) = v(i,j,k) + US%m_s_to_L_T*Waves%Us_y(i,j,k) + if (do_i(i)) v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) enddo ; enddo ; endif if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie @@ -428,7 +432,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! When mixing down Eulerian current + Stokes drift subtract after calling solver if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie - if (do_i(i)) v(i,J,k) = v(i,J,k) - US%m_s_to_L_T*Waves%Us_y(i,J,k) + if (do_i(i)) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) enddo ; enddo ; endif enddo ! end of v-component J loop @@ -499,6 +503,25 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & deallocate(hf_dv_dt_visc_2d) endif + if (CS%id_h_du_dt_visc > 0) then + allocate(h_du_dt_visc(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_du_dt_visc(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_du_dt_visc(I,j,k) = ADp%du_dt_visc(I,j,k) * ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_du_dt_visc, h_du_dt_visc, CS%diag) + deallocate(h_du_dt_visc) + endif + if (CS%id_h_dv_dt_visc > 0) then + allocate(h_dv_dt_visc(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_dv_dt_visc(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_dv_dt_visc(i,J,k) = ADp%dv_dt_visc(i,J,k) * ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_dv_dt_visc, h_dv_dt_visc, CS%diag) + deallocate(h_dv_dt_visc) + endif + end subroutine vertvisc !> Calculate the fraction of momentum originally in a layer that remains @@ -1773,20 +1796,22 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & - 'Thickness at Zonal Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Thickness at Zonal Velocity Points for Viscosity', & + thickness_units, conversion=GV%H_to_MKS) + ! Alternately, to always give this variable in 'm' use the following line instead: + ! 'm', conversion=GV%H_to_m) CS%id_h_v = register_diag_field('ocean_model', 'Hv_visc', diag%axesCvL, Time, & - 'Thickness at Meridional Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Thickness at Meridional Velocity Points for Viscosity', & + thickness_units, conversion=GV%H_to_MKS) CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & - 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', & + thickness_units, conversion=GV%H_to_MKS) CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & - 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', & + thickness_units, conversion=GV%H_to_MKS) CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, & Time, 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) @@ -1796,15 +1821,15 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & if (CS%id_dv_dt_visc > 0) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) CS%id_taux_bot = register_diag_field('ocean_model', 'taux_bot', diag%axesCu1, & - Time, 'Zonal Bottom Stress from Ocean to Earth', 'Pa', & - conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + Time, 'Zonal Bottom Stress from Ocean to Earth', & + 'Pa', conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) CS%id_tauy_bot = register_diag_field('ocean_model', 'tauy_bot', diag%axesCv1, & - Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & - conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + Time, 'Meridional Bottom Stress from Ocean to Earth', & + 'Pa', conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) !CS%id_hf_du_dt_visc = register_diag_field('ocean_model', 'hf_du_dt_visc', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !if (CS%id_hf_du_dt_visc > 0) then ! call safe_alloc_ptr(CS%hf_du_dt_visc,IsdB,IedB,jsd,jed,nz) ! call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) @@ -1812,8 +1837,8 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & !endif !CS%id_hf_dv_dt_visc = register_diag_field('ocean_model', 'hf_dv_dt_visc', diag%axesCvL, Time, & - ! 'Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !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) @@ -1821,21 +1846,37 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & !endif CS%id_hf_du_dt_visc_2d = register_diag_field('ocean_model', 'hf_du_dt_visc_2d', diag%axesCu1, Time, & - 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_du_dt_visc_2d > 0) then call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) endif CS%id_hf_dv_dt_visc_2d = register_diag_field('ocean_model', 'hf_dv_dt_visc_2d', diag%axesCv1, Time, & - 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', & + 'm s-2', 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,JsdB,JedB,nz) endif + CS%id_h_du_dt_visc = register_diag_field('ocean_model', 'h_du_dt_visc', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Horizontal Viscosity', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_du_dt_visc > 0) then + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_h_dv_dt_visc = register_diag_field('ocean_model', 'h_dv_dt_visc', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Horizontal Viscosity', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_dv_dt_visc > 0) then + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%diag_hv,isd,ied,JsdB,JedB,nz) + endif + if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & call PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS%PointAccel_CSp) @@ -1847,7 +1888,7 @@ end subroutine vertvisc_init subroutine updateCFLtruncationValue(Time, CS, activate) type(time_type), target, intent(in) :: Time !< Current model time type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure - logical, optional, intent(in) :: activate !< Specifiy whether to record the value of + logical, optional, intent(in) :: activate !< Specify whether to record the value of !! Time as the beginning of the ramp period ! Local variables @@ -1883,14 +1924,16 @@ end subroutine updateCFLtruncationValue !> Clean up and deallocate the vertical friction module subroutine vertvisc_end(CS) - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure that - !! will be deallocated in this subroutine. + type(vertvisc_CS), intent(inout) :: CS !< Vertical viscosity control structure that + !! will be deallocated in this subroutine. + + if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & + deallocate(CS%PointAccel_CSp) DEALLOC_(CS%a_u) ; DEALLOC_(CS%h_u) DEALLOC_(CS%a_v) ; DEALLOC_(CS%h_v) if (associated(CS%a1_shelf_u)) deallocate(CS%a1_shelf_u) if (associated(CS%a1_shelf_v)) deallocate(CS%a1_shelf_v) - deallocate(CS) end subroutine vertvisc_end !> \namespace mom_vert_friction diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 4e5813e42a..a1039fd1b7 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -458,9 +458,9 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! The -GV%Rho0 changes the sign convention of the flux and changes the units ! of the flux from [Conc. m s-1] to [Conc. kg m-2 T-1]. call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, CFC11_flux, & - scale_factor=-G%US%R_to_kg_m3*GV%Rho0*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%R_to_kg_m3*US%T_to_s, idim=idim, jdim=jdim) call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, CFC12_flux, & - scale_factor=-G%US%R_to_kg_m3*GV%Rho0*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%R_to_kg_m3*US%T_to_s, idim=idim, jdim=jdim) ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. @@ -506,7 +506,8 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: OCMIP2_CFC_stock !< The number of stocks calculated here. ! Local variables - real :: mass + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] + real :: mass ! The cell volume or mass [H L2 ~> m3 or kg] integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -524,14 +525,15 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, CS, names, units, stock_index) call query_vardesc(CS%CFC12_desc, name=names(2), units=units(2), caller="OCMIP2_CFC_stock") units(1) = trim(units(1))//" kg" ; units(2) = trim(units(2))//" kg" + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 stocks(1) = 0.0 ; stocks(2) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - mass = G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k) + mass = G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k) stocks(1) = stocks(1) + CS%CFC11(i,j,k) * mass stocks(2) = stocks(2) + CS%CFC12(i,j,k) * mass enddo ; enddo ; enddo - stocks(1) = GV%H_to_kg_m2 * stocks(1) - stocks(2) = GV%H_to_kg_m2 * stocks(2) + stocks(1) = stock_scale * stocks(1) + stocks(2) = stock_scale * stocks(2) OCMIP2_CFC_stock = 2 diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 9f39237211..f4120155b2 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -582,7 +582,8 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde integer :: MOM_generic_tracer_stock !< Return value, the !! number of stocks calculated here. -! Local variables + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr @@ -603,6 +604,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 m=1 ; g_tracer=>CS%g_tracer_list do call g_tracer_get_alias(g_tracer,names(m)) @@ -613,10 +615,9 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde stocks(m) = 0.0 tr_ptr => tr_field(:,:,:,1) do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + tr_ptr(i,j,k) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + tr_ptr(i,j,k) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 1bf7401cbd..03b89be1a4 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -334,12 +334,16 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! TODO: add similar code for BOTTOM boundary layer endif - if (.not.CS%remap_answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + + if (.not. CS%continuous_reconstruction) then + if (CS%remap_answers_2018) then + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + endif endif ! If doing along isopycnal diffusion (as opposed to neutral diffusion, set the reference pressure) @@ -574,10 +578,12 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real :: Idt ! The inverse of the time step [T-1 ~> s-1] real :: h_neglect, h_neglect_edge - if (.not.CS%remap_answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - else - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + + if (.not. CS%continuous_reconstruction) then + if (CS%remap_answers_2018) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + endif endif nk = GV%ke diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index cfbdc6ecb0..766d6ae7c8 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -104,12 +104,14 @@ module MOM_tracer_registry !! names of flux diagnostics. character(len=64) :: flux_longname = "" !< A word or phrase used construct the long !! names of flux diagnostics. - real :: flux_scale= 1.0 !< A scaling factor used to convert the fluxes - !! of this tracer to its desired units. + real :: flux_scale = 1.0 !< A scaling factor used to convert the fluxes + !! of this tracer to its desired units, + !! including a factor compensating for H scaling. character(len=48) :: flux_units = "" !< The units for fluxes of this variable. character(len=48) :: conv_units = "" !< The units for the flux convergence of this tracer. real :: conv_scale = 1.0 !< A scaling factor used to convert the flux - !! convergence of this tracer to its desired units. + !! convergence of this tracer to its desired units, + !! including a factor compensating for H scaling. character(len=48) :: cmor_tendprefix = "" !< The CMOR variable prefix for tendencies of this !! tracer, required because CMOR does not follow any !! discernable pattern for these names. @@ -279,7 +281,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit Tr%flux_units = "" if (present(flux_units)) Tr%flux_units = flux_units - Tr%flux_scale = 1.0 + Tr%flux_scale = GV%H_to_MKS if (present(flux_scale)) Tr%flux_scale = flux_scale Tr%conv_units = "" @@ -288,7 +290,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit Tr%cmor_tendprefix = "" if (present(cmor_tendprefix)) Tr%cmor_tendprefix = cmor_tendprefix - Tr%conv_scale = 1.0 + Tr%conv_scale = GV%H_to_MKS if (present(convergence_scale)) then Tr%conv_scale = convergence_scale elseif (present(flux_scale)) then @@ -307,10 +309,8 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit if (present(df_x)) then ; if (associated(df_x)) Tr%df_x => df_x ; endif if (present(df_y)) then ; if (associated(df_y)) Tr%df_y => df_y ; endif ! if (present(OBC_inflow)) Tr%OBC_inflow_conc = OBC_inflow -! if (present(OBC_in_u)) then ; if (associated(OBC_in_u)) & -! Tr%OBC_in_u => OBC_in_u ; endif -! if (present(OBC_in_v)) then ; if (associated(OBC_in_v)) & -! Tr%OBC_in_v => OBC_in_v ; endif +! if (present(OBC_in_u)) then ; if (associated(OBC_in_u)) Tr%OBC_in_u => OBC_in_u ; endif +! if (present(OBC_in_v)) then ; if (associated(OBC_in_v)) Tr%OBC_in_v => OBC_in_v ; endif if (present(ad_2d_x)) then ; if (associated(ad_2d_x)) Tr%ad2d_x => ad_2d_x ; endif if (present(ad_2d_y)) then ; if (associated(ad_2d_y)) Tr%ad2d_y => ad_2d_y ; endif if (present(df_2d_x)) then ; if (associated(df_2d_x)) Tr%df2d_x => df_2d_x ; endif @@ -348,7 +348,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< current model time type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output logical, intent(in) :: use_ALE !< If true active diagnostics that only @@ -403,49 +403,49 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) if (len_trim(cmorname) == 0) then Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & - Time, trim(longname), trim(units)) + Time, trim(longname), trim(units)) else Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & - Time, trim(longname), trim(units), cmor_field_name=cmorname, & - cmor_long_name=cmor_longname, cmor_units=Tr%cmor_units, & - cmor_standard_name=cmor_long_std(cmor_longname)) + Time, trim(longname), trim(units), cmor_field_name=cmorname, & + cmor_long_name=cmor_longname, cmor_units=Tr%cmor_units, & + cmor_standard_name=cmor_long_std(cmor_longname)) endif - Tr%id_tr_post_horzn = register_diag_field("ocean_model", & - trim(name)//"_post_horzn", diag%axesTL, Time, & - trim(longname)//" after horizontal transport (advection/diffusion) "//& - "has occurred", trim(units)) + Tr%id_tr_post_horzn = register_diag_field("ocean_model", & + trim(name)//"_post_horzn", diag%axesTL, Time, & + trim(longname)//" after horizontal transport (advection/diffusion) has occurred", & + trim(units)) if (Tr%diag_form == 1) then Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, trim(flux_longname)//" advective zonal flux" , & - trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & + trim(flux_units), v_extensive=.true., y_cell_method='sum', & conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, trim(flux_longname)//" advective meridional flux" , & - trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & + trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_dfx", & diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux" , & - trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & + trim(flux_units), v_extensive=.true., y_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_dfy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive zonal flux" , & - trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & + trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral boundary diffusion "//& - "scheme", trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & + "scheme", trim(flux_units), v_extensive=.true., y_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral boundary diffusion "//& - "scheme", trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & + "scheme", trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, "Advective (by residual mean) Zonal Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, y_cell_method = 'sum') + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, y_cell_method='sum') Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, "Advective (by residual mean) Meridional Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method = 'sum') + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method='sum') Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_diffx", & diag%axesCuL, Time, "Diffusive Zonal Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & @@ -473,11 +473,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & "Vertically Integrated Advective Zonal Flux of "//trim(flux_longname), & - flux_units, conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, y_cell_method = 'sum') + flux_units, conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, y_cell_method='sum') Tr%id_ady_2d = register_diag_field("ocean_model", trim(shortnm)//"_ady_2d", & diag%axesCv1, Time, & "Vertically Integrated Advective Meridional Flux of "//trim(flux_longname), & - flux_units, conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method = 'sum') + flux_units, conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method='sum') Tr%id_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_diffx_2d", & diag%axesCu1, Time, & "Vertically Integrated Diffusive Zonal Flux of "//trim(flux_longname), & @@ -499,13 +499,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx_2d", & - diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion "//& - "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - y_cell_method = 'sum') + diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion "//& + "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + y_cell_method='sum') Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy_2d", & - diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion "//& - "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - x_cell_method = 'sum') + diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion "//& + "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + x_cell_method='sum') if (Tr%id_adx_2d > 0) call safe_alloc_ptr(Tr%ad2d_x,IsdB,IedB,jsd,jed) if (Tr%id_ady_2d > 0) call safe_alloc_ptr(Tr%ad2d_y,isd,ied,JsdB,JedB) @@ -518,9 +518,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_adv_xy = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy", & diag%axesTL, Time, & - 'Horizontal convergence of residual mean advective fluxes of '//& - trim(lowercase(flux_longname)), conv_units, v_extensive=.true., & - conversion=Tr%conv_scale*US%s_to_T) + 'Horizontal convergence of residual mean advective fluxes of '//trim(lowercase(flux_longname)), & + conv_units, v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) Tr%id_adv_xy_2d = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy_2d", & diag%axesT1, Time, & 'Vertical sum of horizontal convergence of residual mean advective fluxes of '//& @@ -548,7 +547,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated neutral diffusion tracer content "//& "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method= 'sum') + x_cell_method='sum', y_cell_method='sum') Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & @@ -557,35 +556,34 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated lateral diffusion tracer content "//& "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method= 'sum') + x_cell_method='sum', y_cell_method='sum') else - cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//& - ' expressed as '//trim(lowercase(flux_longname))//& - ' content due to parameterized mesoscale neutral diffusion' + cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& + trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & - conv_units, conversion=Tr%conv_scale*US%s_to_T, cmor_field_name = trim(Tr%cmor_tendprefix)//'pmdiff', & - cmor_long_name = trim(cmor_var_lname), cmor_standard_name = trim(cmor_long_std(cmor_var_lname)), & - x_cell_method = 'sum', y_cell_method = 'sum', v_extensive = .true.) + conv_units, conversion=Tr%conv_scale*US%s_to_T, cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff', & + cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & + x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated neutral diffusion tracer "//& - "content tendency for "//trim(shortnm), conv_units, & - conversion=Tr%conv_scale*US%s_to_T, cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff_2d', & + "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & + cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff_2d', & cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & x_cell_method='sum', y_cell_method='sum') Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method = 'sum', y_cell_method = 'sum', v_extensive = .true.) + x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated lateral diffusion tracer "//& - "content tendency for "//trim(shortnm), conv_units, & - conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum') + "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & + x_cell_method='sum', y_cell_method='sum') endif Tr%id_dfxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_conc_tendency', & diag%axesTL, Time, "Neutral diffusion tracer concentration tendency for "//trim(shortnm), & @@ -598,25 +596,25 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) var_lname = "Net time tendency for "//lowercase(flux_longname) if (len_trim(Tr%cmor_tendprefix) == 0) then Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & - diag%axesTL, Time, var_lname, conv_units, v_extensive=.true., & - conversion=Tr%conv_scale*US%s_to_T) + diag%axesTL, Time, var_lname, conv_units, conversion=Tr%conv_scale*US%s_to_T, & + v_extensive=.true.) Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & - diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units, & - conversion=Tr%conv_scale*US%s_to_T) + diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), & + conv_units, conversion=Tr%conv_scale*US%s_to_T) else cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//& trim(flux_longname)//" Content" Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & - diag%axesTL, Time, var_lname, conv_units, & + diag%axesTL, Time, var_lname, conv_units, conversion=Tr%conv_scale*US%s_to_T, & cmor_field_name=trim(Tr%cmor_tendprefix)//"tend", & cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & - v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) + v_extensive=.true.) cmor_var_lname = trim(cmor_var_lname)//" Vertical Sum" Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & - diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units, & + diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, & cmor_field_name=trim(Tr%cmor_tendprefix)//"tend_2d", & - cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & - conversion=Tr%conv_scale*US%s_to_T) + cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname) endif if ((Tr%id_trxh_tendency > 0) .or. (Tr%id_trxh_tendency_2d > 0)) then call safe_alloc_ptr(Tr%Trxh_prev,isd,ied,jsd,jed,nz) @@ -628,20 +626,20 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) ! Vertical regridding/remapping tendencies if (use_ALE .and. Tr%remap_tr) then var_lname = "Vertical remapping tracer concentration tendency for "//trim(Reg%Tr(m)%name) - Tr%id_remap_conc= register_diag_field('ocean_model', & - trim(Tr%flux_nameroot)//'_tendency_vert_remap', diag%axesTL, Time, var_lname, & - trim(units)//' s-1', conversion=US%s_to_T) + Tr%id_remap_conc= register_diag_field('ocean_model', & + trim(Tr%flux_nameroot)//'_tendency_vert_remap', diag%axesTL, Time, var_lname, & + trim(units)//' s-1', conversion=US%s_to_T) var_lname = "Vertical remapping tracer content tendency for "//trim(Reg%Tr(m)%flux_longname) Tr%id_remap_cont = register_diag_field('ocean_model', & - trim(Tr%flux_nameroot)//'h_tendency_vert_remap', & - diag%axesTL, Time, var_lname, flux_units, v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) + trim(Tr%flux_nameroot)//'h_tendency_vert_remap', & + diag%axesTL, Time, var_lname, conv_units, v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) var_lname = "Vertical sum of vertical remapping tracer content tendency for "//& trim(Reg%Tr(m)%flux_longname) Tr%id_remap_cont_2d = register_diag_field('ocean_model', & - trim(Tr%flux_nameroot)//'h_tendency_vert_remap_2d', & - diag%axesT1, Time, var_lname, flux_units, conversion=Tr%conv_scale*US%s_to_T) + trim(Tr%flux_nameroot)//'h_tendency_vert_remap_2d', & + diag%axesT1, Time, var_lname, conv_units, conversion=Tr%conv_scale*US%s_to_T) endif @@ -649,7 +647,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) unit2 = trim(units)//"2" if (index(units(1:len_trim(units))," ") > 0) unit2 = "("//trim(units)//")2" Tr%id_tr_vardec = register_diag_field('ocean_model', trim(shortnm)//"_vardec", diag%axesTL, & - Time, "ALE variance decay for "//lowercase(longname), trim(unit2)//" s-1", conversion=US%s_to_T) + Time, "ALE variance decay for "//lowercase(longname), trim(unit2)//" s-1", conversion=US%s_to_T) if (Tr%id_tr_vardec > 0) then ! Set up a new tracer for this tracer squared m2 = Reg%ntr+1 @@ -721,7 +719,7 @@ subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(diag_grid_storage), intent(in) :: diag_prev !< Contains diagnostic grids from previous timestep type(diag_ctrl), intent(inout) :: diag !< structure to regulate diagnostic output real, intent(in) :: dt !< total time step for tracer updates [T ~> s] @@ -774,7 +772,7 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_diag !< Layer thicknesses on which to post fields + intent(in) :: h_diag !< Layer thicknesses on which to post fields [H ~> m or kg m-2] type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output integer :: i, j, k, is, ie, js, je, nz, m @@ -827,18 +825,21 @@ subroutine MOM_tracer_chkinv(mesg, G, GV, h, Tr, ntr) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_type), dimension(:), intent(in) :: Tr !< array of all of registered tracers - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] integer, intent(in) :: ntr !< number of registered tracers - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tr_inv !< Tracer inventory - real :: total_inv + ! Local variables + real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> nondim or m3 kg-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tr_inv ! Volumetric tracer inventory in each cell [conc m3] + real :: total_inv ! The total amount of tracer [conc m3] integer :: is, ie, js, je, nz integer :: i, j, k, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + vol_scale = GV%H_to_m*G%US%L_to_m**2 do m=1,ntr do k=1,nz ; do j=js,je ; do i=is,ie - tr_inv(i,j,k) = Tr(m)%t(i,j,k)*h(i,j,k)*G%US%L_to_m**2*G%areaT(i,j)*G%mask2dT(i,j) + tr_inv(i,j,k) = Tr(m)%t(i,j,k) * (vol_scale * h(i,j,k) * G%areaT(i,j)*G%mask2dT(i,j)) enddo ; enddo ; enddo total_inv = reproducing_sum(tr_inv, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) if (is_root_pe()) write(0,'(A,1X,A5,1X,ES25.16,1X,A)') "h-point: inventory", Tr(m)%name, total_inv, mesg diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index a051fe3da9..9d328e7a8f 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -357,6 +357,8 @@ function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) integer, optional, intent(in) :: stock_index !< the coded index of a specific stock being sought. integer :: advection_test_stock !< the number of stocks calculated here. + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -371,14 +373,14 @@ function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="advection_test_stock") stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo advection_test_stock = CS%ntr diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 55f061da20..4856abaefd 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -280,6 +280,9 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, end subroutine boundary_impulse_tracer_column_physics !> Calculate total inventory of tracer +!> This function calculates the mass-weighted integral of the boundary impulse, +!! tracer stocks returning the number of stocks it has calculated. If the stock_index +!! is present, only the stock corresponding to that coded index is returned. function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure @@ -299,6 +302,7 @@ function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) ! is present, only the stock corresponding to that coded index is returned. ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -313,15 +317,15 @@ function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,1 call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="boundary_impulse_stock") units(m) = trim(units(m))//" kg" stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo boundary_impulse_stock = CS%ntr diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index ccb1a3635b..2919f2d95f 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -338,7 +338,8 @@ function dye_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: dye_stock !< Return value: the number of stocks !! calculated here. -! Local variables + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -353,15 +354,15 @@ function dye_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="dye_stock") units(m) = trim(units(m))//" kg" stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo dye_stock = CS%ntr diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 31d13c811e..19e1df59dc 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -383,10 +383,9 @@ function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) integer, optional, intent(in) :: stock_index !< the coded index of a specific stock !! being sought. integer :: ideal_age_stock !< The number of stocks calculated here. -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -401,15 +400,15 @@ function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="ideal_age_stock") units(m) = trim(units(m))//" kg" stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo ideal_age_stock = CS%ntr diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index e73562dc1d..df96193181 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -38,23 +38,19 @@ module oil_tracer logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. character(len=200) :: IC_file !< The file in which the age-tracer initial values !! can be found, or an empty string for internal initialization. - logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. + logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. real :: oil_source_longitude !< Latitude of source location (geographic) real :: oil_source_latitude !< Longitude of source location (geographic) integer :: oil_source_i=-999 !< Local i of source location (computational) integer :: oil_source_j=-999 !< Local j of source location (computational) real :: oil_source_rate !< Rate of oil injection [kg T-1 ~> kg s-1] - real :: oil_start_year !< The year in which tracers start aging, or at which the - !! surface value equals young_val, in years. - real :: oil_end_year !< The year in which tracers start aging, or at which the - !! surface value equals young_val, in years. + real :: oil_start_year !< The time at which the oil source starts [years] + real :: oil_end_year !< The time at which the oil source ends [years] type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. - real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface. real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. - real, dimension(NTR_MAX) :: sfc_growth_rate !< The exponential growth rate for the surface value [year-1]. real, dimension(NTR_MAX) :: oil_decay_days !< Decay time scale of oil [days] real, dimension(NTR_MAX) :: oil_decay_rate !< Decay rate of oil [T-1 ~> s-1] calculated from oil_decay_days integer, dimension(NTR_MAX) :: oil_source_k !< Layer of source @@ -138,7 +134,8 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) "negative number for a vertically uniform source, "//& "or 0 not to use this tracer.", units="Layer", default=0) call get_param(param_file, mdl, "OIL_SOURCE_RATE", CS%oil_source_rate, & - "The rate of oil injection.", units="kg s-1", scale=US%T_to_s, default=1.0) + "The rate of oil injection.", & + units="kg s-1", scale=US%T_to_s, default=1.0) call get_param(param_file, mdl, "OIL_DECAY_DAYS", CS%oil_decay_days, & "The decay timescale in days (if positive), or no decay "//& "if 0, or use the temperature dependent decay rate of "//& @@ -258,8 +255,7 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & if (len_trim(CS%IC_file) > 0) then ! Read the tracer concentrations from a netcdf file. if (.not.file_exists(CS%IC_file, G%Domain)) & - call MOM_error(FATAL, "initialize_oil_tracer: "// & - "Unable to open "//CS%IC_file) + call MOM_error(FATAL, "initialize_oil_tracer: Unable to open "//CS%IC_file) if (CS%Z_IC_file) then OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, name, & @@ -331,6 +327,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] real :: Isecs_per_year = 1.0 / (365.0*86400.0) + real :: vol_scale ! A conversion factor for volumes into m3 [m3 H-1 L-2 ~> nondim or m3 kg-1] real :: year, h_total, ldecay integer :: i, j, k, is, ie, js, je, nz, m, k_max is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -375,6 +372,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US CS%oil_source_i>-999 .and. CS%oil_source_j>-999) then i=CS%oil_source_i ; j=CS%oil_source_j k_max=nz ; h_total=0. + vol_scale = GV%H_to_m * US%L_to_m**2 do k=nz, 2, -1 h_total = h_total + h_new(i,j,k) if (h_total<10.) k_max=k-1 ! Find bottom most interface that is 10 m above bottom @@ -384,15 +382,14 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US if (k>0) then k=min(k,k_max) ! Only insert k or first layer with interface 10 m above bottom CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt / & - ((h_new(i,j,k)+GV%H_subroundoff) * G%US%L_to_m**2*G%areaT(i,j) ) + (vol_scale * (h_new(i,j,k)+GV%H_subroundoff) * G%areaT(i,j) ) elseif (k<0) then h_total=GV%H_subroundoff do k=1, nz h_total = h_total + h_new(i,j,k) enddo do k=1, nz - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt/(h_total & - * G%US%L_to_m**2*G%areaT(i,j) ) + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt / (vol_scale * h_total * G%areaT(i,j) ) enddo endif enddo @@ -416,11 +413,8 @@ function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) !! being sought. integer :: oil_stock !< The number of stocks calculated here. -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. - ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -435,15 +429,15 @@ function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="oil_stock") units(m) = trim(units(m))//" kg" stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo oil_stock = CS%ntr diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 9cb94a3054..eb15c05580 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -261,10 +261,8 @@ function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: pseudo_salt_stock !< Return value: the number of !! stocks calculated here. -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. - + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -279,14 +277,14 @@ function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 call query_vardesc(CS%tr_desc, name=names(1), units=units(1), caller="pseudo_salt_stock") units(1) = trim(units(1))//" kg" stocks(1) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(1) = stocks(1) + CS%diff(i,j,k) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(1) = stocks(1) + CS%diff(i,j,k) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(1) = GV%H_to_kg_m2 * stocks(1) + stocks(1) = stock_scale * stocks(1) pseudo_salt_stock = 1 diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 395eec50c5..349720304b 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -373,7 +373,8 @@ function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: USER_tracer_stock !< Return value: the number of !! stocks calculated here. -! Local variables + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -387,15 +388,15 @@ function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,NTR call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="USER_tracer_stock") units(m) = trim(units(m))//" kg" stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo USER_tracer_stock = NTR diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index b93007647d..4a136dd2db 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -35,13 +35,13 @@ module Kelvin_initialization !> Control structure for Kelvin wave open boundaries. type, public :: Kelvin_OBC_CS ; private integer :: mode = 0 !< Vertical mode - real :: coast_angle = 0 !< Angle of coastline - real :: coast_offset1 = 0 !< Longshore distance to coastal angle - real :: coast_offset2 = 0 !< Longshore distance to coastal angle - real :: H0 = 0 !< Bottom depth - real :: F_0 !< Coriolis parameter - real :: rho_range !< Density range - real :: rho_0 !< Mean density + real :: coast_angle = 0 !< Angle of coastline [rad] + real :: coast_offset1 = 0 !< Longshore distance to coastal angle [L ~> m] + real :: coast_offset2 = 0 !< Longshore distance to coastal angle [L ~> m] + real :: H0 = 0 !< Bottom depth [Z ~> m] + real :: F_0 !< Coriolis parameter [T-1 ~> s-1] + real :: rho_range !< Density range [R ~> kg m-3] + real :: rho_0 !< Mean density [R ~> kg m-3] end type Kelvin_OBC_CS ! This include declares and sets the variable "version". @@ -50,9 +50,10 @@ module Kelvin_initialization contains !> Add Kelvin wave to OBC registry. -function register_Kelvin_OBC(param_file, CS, OBC_Reg) +function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. ! Local variables @@ -73,31 +74,29 @@ function register_Kelvin_OBC(param_file, CS, OBC_Reg) "Vertical Kelvin wave mode imposed at upstream open boundary.", & default=0) call get_param(param_file, mdl, "F_0", CS%F_0, & - default=0.0, do_not_log=.true.) + default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) call get_param(param_file, mdl, "TOPO_CONFIG", config, do_not_log=.true.) if (trim(config) == "Kelvin") then call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_1", CS%coast_offset1, & "The distance along the southern and northern boundaries "//& "at which the coasts angle in.", & - units="km", default=100.0) + units="km", default=100.0, scale=1.0e3*US%m_to_L) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_2", CS%coast_offset2, & "The distance from the southern and northern boundaries "//& "at which the coasts angle in.", & - units="km", default=10.0) + units="km", default=10.0, scale=1.0e3*US%m_to_L) call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", CS%coast_angle, & "The angle of the southern bondary beyond X=ROTATED_COAST_OFFSET.", & units="degrees", default=11.3) CS%coast_angle = CS%coast_angle * (atan(1.0)/45.) ! Convert to radians - CS%coast_offset1 = CS%coast_offset1 * 1.e3 ! Convert to m - CS%coast_offset2 = CS%coast_offset2 * 1.e3 ! Convert to m endif if (CS%mode /= 0) then call get_param(param_file, mdl, "DENSITY_RANGE", CS%rho_range, & - default=2.0, do_not_log=.true.) + default=2.0, do_not_log=.true., scale=US%kg_m3_to_R) call get_param(param_file, mdl, "RHO_0", CS%rho_0, & - default=1035.0, do_not_log=.true.) + default=1035.0, do_not_log=.true., scale=US%kg_m3_to_R) call get_param(param_file, mdl, "MAXIMUM_DEPTH", CS%H0, & - default=1000.0, do_not_log=.true.) + default=1000.0, do_not_log=.true., scale=US%m_to_Z) endif ! Register the Kelvin open boundary. @@ -122,7 +121,7 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(out) :: D !< Ocean bottom depth in m or Z if US is present type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum model depth in the units of D + real, intent(in) :: max_depth !< Maximum model depth in the units of D [Z ~> m or m] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables @@ -176,22 +175,27 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2]. type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the Kelvin example. - real :: time_sec, cff - real :: N0 ! Brunt-Vaisala frequency [s-1] - real :: plx !< Longshore wave parameter - real :: pmz !< Vertical wave parameter - real :: lambda !< Offshore decay scale - real :: omega !< Wave frequency [s-1] + real :: time_sec ! The time in the run [T ~> s] + real :: cff ! The wave speed [L T-1 ~> m s-1] + real :: N0 ! Brunt-Vaisala frequency times a rescaling of slopes [L Z-1 T-1 ~> s-1] + real :: lambda ! Offshore decay scale [L-1 ~> m-1] + real :: omega ! Wave frequency [T-1 ~> s-1] real :: PI integer :: i, j, k, n, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB - real :: fac, x, y, x1, y1 - real :: val1, val2, sina, cosa + real :: mag_SSH ! An overall magnitude of the external wave sea surface height at the coastline [Z ~> m] + real :: mag_int ! An overall magnitude of the internal wave at the coastline [L2 T-2 ~> m2 s-2] + real :: x1, y1 ! Various positions [L ~> m] + real :: x, y ! Various positions [L ~> m] + real :: val1 ! The periodicity factor [nondim] + real :: val2 ! The local wave amplitude [Z ~> m] + real :: km_to_L_scale ! A scaling factor from longitudes in km to L [L km-1 ~> 1e3] + real :: sina, cosa ! The sine and cosine of the coast angle [nondim] type(OBC_segment_type), pointer :: segment => NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -201,23 +205,20 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (.not.associated(OBC)) call MOM_error(FATAL, 'Kelvin_initialization.F90: '// & 'Kelvin_set_OBC_data() was called but OBC type was not initialized!') - time_sec = time_type_to_real(Time) + time_sec = US%s_to_T*time_type_to_real(Time) PI = 4.0*atan(1.0) - fac = 1.0 + km_to_L_scale = 1000.0*US%m_to_L if (CS%mode == 0) then - omega = 2.0 * PI / (12.42 * 3600.0) ! M2 Tide period - val1 = US%m_to_Z * sin(omega * time_sec) + mag_SSH = 1.0*US%m_to_Z + omega = 2.0 * PI / (12.42 * 3600.0*US%s_to_T) ! M2 Tide period + val1 = sin(omega * time_sec) else - N0 = US%L_to_m*US%s_to_T * sqrt((CS%rho_range / CS%rho_0) * GV%g_Earth * (US%m_to_Z * CS%H0)) + mag_int = 1.0*US%m_s_to_L_T**2 + N0 = sqrt((CS%rho_range / CS%rho_0) * (GV%g_Earth / CS%H0)) + lambda = PI * CS%mode * CS%F_0 / (CS%H0 * N0) ! Two wavelengths in domain - plx = 4.0 * PI / G%len_lon - pmz = PI * CS%mode / CS%H0 - lambda = pmz * CS%F_0 / N0 - omega = CS%F_0 * plx / lambda - - ! lambda = PI * CS%mode * CS%F_0 / (CS%H0 * N0) - ! omega = (4.0 * CS%H0 * N0) / (CS%mode * G%len_lon) + omega = (4.0 * CS%H0 * N0) / (CS%mode * US%m_to_L*G%len_lon) endif sina = sin(CS%coast_angle) @@ -230,22 +231,23 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (segment%direction == OBC_DIRECTION_N) cycle ! This should be somewhere else... - segment%Velocity_nudging_timescale_in = 1.0/(0.3*86400) + !### This is supposed to be a timescale [T ~> s] but appears to be a rate in [s-1]. + segment%Velocity_nudging_timescale_in = US%s_to_T * 1.0/(0.3*86400) if (segment%direction == OBC_DIRECTION_W) then IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB jsd = segment%HI%jsd ; jed = segment%HI%jed JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do j=jsd,jed ; do I=IsdB,IedB - x1 = 1000. * G%geoLonCu(I,j) - y1 = 1000. * G%geoLatCu(I,j) + x1 = km_to_L_scale * G%geoLonCu(I,j) + y1 = km_to_L_scale * G%geoLatCu(I,j) x = (x1 - CS%coast_offset1) * cosa + y1 * sina - y = - (x1 - CS%coast_offset1) * sina + y1 * cosa + y = -(x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then ! Use inside bathymetry cff = sqrt(GV%g_Earth * G%bathyT(i+1,j) ) - val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) - segment%eta(I,j) = val2 * cos(omega * time_sec) + val2 = mag_SSH * exp(- CS%F_0 * y / cff) + segment%eta(I,j) = GV%Z_to_H*val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = (val2 * (val1 * cff * cosa / & (G%bathyT(i+1,j) )) ) if (segment%nudged) then @@ -261,19 +263,19 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo endif else - ! Not rotated yet + ! Baroclinic, not rotated yet segment%eta(I,j) = 0.0 segment%normal_vel_bt(I,j) = 0.0 if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = US%m_s_to_L_T * fac * lambda / CS%F_0 * & - exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & + segment%nudged_normal_vel(I,j,k) = mag_int * lambda / CS%F_0 * & + exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & cos(omega * time_sec) enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = US%m_s_to_L_T * fac * lambda / CS%F_0 * & - exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & + segment%normal_vel(I,j,k) = mag_int * lambda / CS%F_0 * & + exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & cos(omega * time_sec) segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) enddo @@ -282,12 +284,12 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo ; enddo if (associated(segment%tangential_vel)) then do J=JsdB+1,JedB-1 ; do I=IsdB,IedB - x1 = 1000. * G%geoLonBu(I,J) - y1 = 1000. * G%geoLatBu(I,J) + x1 = km_to_L_scale * G%geoLonBu(I,J) + y1 = km_to_L_scale * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff =sqrt(GV%g_Earth * G%bathyT(i+1,j) ) - val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) + cff = sqrt(GV%g_Earth * G%bathyT(i+1,j) ) + val2 = mag_SSH * exp(- CS%F_0 * y / cff) if (CS%mode == 0) then ; do k=1,nz segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & ( 0.5*(G%bathyT(i+1,j+1) + G%bathyT(i+1,j) ) ) @@ -299,24 +301,24 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do J=JsdB,JedB ; do i=isd,ied - x1 = 1000. * G%geoLonCv(i,J) - y1 = 1000. * G%geoLatCv(i,J) + x1 = km_to_L_scale * G%geoLonCv(i,J) + y1 = km_to_L_scale * G%geoLatCv(i,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) - val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) - segment%eta(I,j) = val2 * cos(omega * time_sec) - segment%normal_vel_bt(I,j) = US%L_T_to_m_s * (val1 * cff * sina / & + val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) + segment%eta(I,j) = GV%Z_to_H*val2 * cos(omega * time_sec) + segment%normal_vel_bt(I,j) = (val1 * cff * sina / & (G%bathyT(i,j+1) )) * val2 if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & + segment%nudged_normal_vel(I,j,k) = (val1 * cff * sina / & (G%bathyT(i,j+1) )) * val2 enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & + segment%normal_vel(I,j,k) = (val1 * cff * sina / & (G%bathyT(i,j+1) )) * val2 segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) enddo @@ -327,12 +329,12 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) segment%normal_vel_bt(i,J) = 0.0 if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(i,J,k) = US%m_s_to_L_T*fac * lambda / CS%F_0 * & + segment%nudged_normal_vel(i,J,k) = mag_int * lambda / CS%F_0 * & exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(i,J,k) = US%m_s_to_L_T*fac * lambda / CS%F_0 * & + segment%normal_vel(i,J,k) = mag_int * lambda / CS%F_0 * & exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) enddo @@ -341,12 +343,12 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo ; enddo if (associated(segment%tangential_vel)) then do J=JsdB,JedB ; do I=IsdB+1,IedB-1 - x1 = 1000. * G%geoLonBu(I,J) - y1 = 1000. * G%geoLatBu(I,J) + x1 = km_to_L_scale * G%geoLonBu(I,J) + y1 = km_to_L_scale * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) - val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) + val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) if (CS%mode == 0) then ; do k=1,nz segment%tangential_vel(I,J,k) = ((val1 * val2 * cff * sina) / & ( 0.5*((G%bathyT(i+1,j+1)) + G%bathyT(i,j+1))) ) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a8e3e207a6..38aa6b13a5 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -12,21 +12,19 @@ module MOM_wave_interface use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, get_var_sizes, read_variable use MOM_safe_alloc, only : safe_alloc_ptr use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, surface use MOM_verticalgrid, only : verticalGrid_type -use netcdf, only : NF90_open, NF90_inq_varid, NF90_inquire_variable, NF90_get_var -use netcdf, only : NF90_inquire_dimension, NF90_close, NF90_NOWRITE, NF90_NOERR - implicit none ; private #include public MOM_wave_interface_init ! Public interface to fully initialize the wave routines. -public MOM_wave_interface_init_lite ! Public interface to quick initialize this module. +public query_wave_properties ! Public interface to obtain information from the waves control structure. public Update_Surface_Waves ! Public interface to update wave information at the ! coupler/driver level. public Update_Stokes_Drift ! Public interface to update the Stokes drift profiles @@ -50,73 +48,97 @@ module MOM_wave_interface !> Container for all surface wave related parameters type, public :: wave_parameters_CS ; private - !Main surface wave options - logical, public :: UseWaves !< Flag to enable surface gravity wave feature - logical, public :: LagrangianMixing !< This feature is in development and not ready + ! Main surface wave options and publicly visible variables + logical, public :: UseWaves = .false. !< Flag to enable surface gravity wave feature + real, allocatable, dimension(:,:,:), public :: & + Us_x !< 3d zonal Stokes drift profile [L T-1 ~> m s-1] + !! Horizontal -> U points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_y !< 3d meridional Stokes drift profile [L T-1 ~> m s-1] + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] + + ! The remainder of this control structure is private + integer :: WaveMethod = -99 !< Options for including wave information + !! Valid (tested) choices are: + !! 0 - Test Profile + !! 1 - Surface Stokes Drift Bands + !! 2 - DHH85 + !! 3 - LF17 + !! -99 - No waves computed, but empirical Langmuir number used. + logical :: LagrangianMixing !< This feature is in development and not ready !! True if Stokes drift is present and mixing !! should be applied to Lagrangian current !! (mean current + Stokes drift). !! See Reichl et al., 2016 KPP-LT approach - logical, public :: StokesMixing !< This feature is in development and not ready. + logical :: StokesMixing !< This feature is in development and not ready. !! True if vertical mixing of momentum !! should be applied directly to Stokes current !! (with separate mixing parameter for Eulerian !! mixing contribution). !! See Harcourt 2013, 2015 Second-Moment approach - logical, public :: CoriolisStokes !< This feature is in development and not ready. + logical :: CoriolisStokes !< This feature is in development and not ready. ! True if Coriolis-Stokes acceleration should be applied. - integer, public :: StkLevelMode=1 !< Sets if Stokes drift is defined at mid-points + integer :: StkLevelMode=1 !< Sets if Stokes drift is defined at mid-points !! or layer averaged. Set to 0 if mid-point and set to !! 1 if average value of Stokes drift over level. !! If advecting with Stokes transport, 1 is the correct !! approach. - - ! Surface Wave Dependent 1d/2d/3d vars - integer, public :: NumBands =0 !< Number of wavenumber/frequency partitions to receive + ! Options if WaveMethod is Surface Stokes Drift Bands (1) + integer :: PartitionMode !< Method for partition mode (meant to check input) + !! 0 - wavenumbers + !! 1 - frequencies + integer :: DataSource !< Integer that specifies where the model Looks for data + !! Valid choices are: + !! 1 - FMS DataOverride Routine + !! 2 - Reserved For Coupler + !! 3 - User input (fixed values, useful for 1d testing) + + ! Options if using FMS DataOverride Routine + character(len=40) :: SurfBandFileName !< Filename if using DataOverride + logical :: DataOver_initialized !< Flag for DataOverride Initialization + + ! Options for computing Langmuir number + real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number + logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number + + integer :: NumBands = 0 !< Number of wavenumber/frequency partitions to receive !! This needs to match the number of bands provided !! via either coupling or file. - real, allocatable, dimension(:), public :: & - WaveNum_Cen !< Wavenumber bands for read/coupled [m-1] - real, allocatable, dimension(:), public :: & - Freq_Cen !< Frequency bands for read/coupled [s-1] - real, allocatable, dimension(:), public :: & - PrescribedSurfStkX !< Surface Stokes drift if prescribed [m s-1] - real, allocatable, dimension(:), public :: & - PrescribedSurfStkY !< Surface Stokes drift if prescribed [m s-1] - real, allocatable, dimension(:,:,:), public :: & - Us_x !< 3d zonal Stokes drift profile [m s-1] - !! Horizontal -> U points - !! Vertical -> Mid-points - real, allocatable, dimension(:,:,:), public :: & - Us_y !< 3d meridional Stokes drift profile [m s-1] - !! Horizontal -> V points - !! Vertical -> Mid-points - real, allocatable, dimension(:,:), public :: & - La_SL,& !< SL Langmuir number (directionality factored later) + real :: g_Earth !< The gravitational acceleration, equivalent to GV%g_Earth but with + !! different dimensional rescaling appropriate for deep-water gravity + !! waves [Z T-2 ~> m s-2] + ! Surface Wave Dependent 1d/2d/3d vars + real, allocatable, dimension(:) :: & + WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] + real, allocatable, dimension(:) :: & + Freq_Cen !< Central frequency for wave bands, including a factor of 2*pi [T-1 ~> s-1] + real, allocatable, dimension(:) :: & + PrescribedSurfStkX !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] + real, allocatable, dimension(:) :: & + PrescribedSurfStkY !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: & + La_SL, & !< SL Langmuir number (directionality factored later) !! Horizontal -> H points - La_Turb !< Aligned Turbulent Langmuir number + La_Turb !< Aligned Turbulent Langmuir number [nondim] !! Horizontal -> H points - real, allocatable, dimension(:,:), public :: & - US0_x !< Surface Stokes Drift (zonal, m/s) + real, allocatable, dimension(:,:) :: & + US0_x !< Surface Stokes Drift (zonal) [L T-1 ~> m s-1] !! Horizontal -> U points - real, allocatable, dimension(:,:), public :: & - US0_y !< Surface Stokes Drift (meridional, m/s) + real, allocatable, dimension(:,:) :: & + US0_y !< Surface Stokes Drift (meridional) [L T-1 ~> m s-1] !! Horizontal -> V points - real, allocatable, dimension(:,:,:), public :: & - STKx0 !< Stokes Drift spectrum (zonal, m/s) + real, allocatable, dimension(:,:,:) :: & + STKx0 !< Stokes Drift spectrum (zonal) [L T-1 ~> m s-1] !! Horizontal -> U points !! 3rd dimension -> Freq/Wavenumber - real, allocatable, dimension(:,:,:), public :: & - STKy0 !< Stokes Drift spectrum (meridional, m/s) + real, allocatable, dimension(:,:,:) :: & + STKy0 !< Stokes Drift spectrum (meridional) [L T-1 ~> m s-1] !! Horizontal -> V points !! 3rd dimension -> Freq/Wavenumber - real, allocatable, dimension(:,:,:), public :: & - KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] - - ! Pointers to auxiliary fields - type(time_type), pointer, public :: Time !< A pointer to the ocean model's clock. - type(diag_ctrl), pointer, public :: diag !< A structure that is used to regulate the - !! timing of diagnostic output. !> An arbitrary lower-bound on the Langmuir number. Run-time parameter. !! Langmuir number is sqrt(u_star/u_stokes). When both are small @@ -125,68 +147,36 @@ module MOM_wave_interface !! to avoid such consequences. real :: La_min = 0.05 + ! Options used with the test profile + real :: TP_STKX0 !< Test profile x-stokes drift amplitude [L T-1 ~> m s-1] + real :: TP_STKY0 !< Test profile y-stokes drift amplitude [L T-1 ~> m s-1] + real :: TP_WVL !< Test profile wavelength [Z ~> m] + + ! Options for use with the Donelan et al., 1985 (DHH85) spectrum + logical :: WaveAgePeakFreq !< Flag to use wave age to determine the peak frequency with DHH85 + logical :: StaticWaves !< Flag to disable updating DHH85 Stokes drift + logical :: DHH85_is_set !< The if the wave properties have been set when WaveMethod = DHH85. + real :: WaveAge !< The fixed wave age used with the DHH85 spectrum [nondim] + real :: WaveWind !< Wind speed for the DHH85 spectrum [L T-1 ~> m s-1] + + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + !>@{ Diagnostic handles - integer, public :: id_surfacestokes_x = -1 , id_surfacestokes_y = -1 - integer, public :: id_3dstokes_x = -1 , id_3dstokes_y = -1 - integer, public :: id_La_turb = -1 + integer :: id_surfacestokes_x = -1 , id_surfacestokes_y = -1 + integer :: id_3dstokes_x = -1 , id_3dstokes_y = -1 + integer :: id_La_turb = -1 !>@} end type wave_parameters_CS -! Options not needed outside of this module - -integer :: WaveMethod=-99 !< Options for including wave information - !! Valid (tested) choices are: - !! 0 - Test Profile - !! 1 - Surface Stokes Drift Bands - !! 2 - DHH85 - !! 3 - LF17 - !! -99 - No waves computed, but empirical Langmuir number used. - !! \todo Module variable! Move into a control structure. - -! Options if WaveMethod is Surface Stokes Drift Bands (1) -integer, public :: PartitionMode !< Method for partition mode (meant to check input) - !! 0 - wavenumbers - !! 1 - frequencies - !! \todo Module variable! Move into a control structure. -integer :: DataSource !< Integer that specifies where the Model Looks for Data - !! Valid choices are: - !! 1 - FMS DataOverride Routine - !! 2 - Reserved For Coupler - !! 3 - User input (fixed values, useful for 1d testing) - !! \todo Module variable! Move into a control structure. - -! Options if using FMS DataOverride Routine -character(len=40) :: SurfBandFileName !< Filename if using DataOverride - !! \todo Module variable! Move into a control structure. -logical :: dataoverrideisinitialized !< Flag for DataOverride Initialization - !! \todo Module variable! Move into a control structure. - -! Options for computing Langmuir number -real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number - !! \todo Module variable! Move into a control structure. -logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number - !! \todo Module variable! Move into a control structure. - -! This include declares and sets the variable "version". -#include "version_variable.h" - -character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. - -!>@{ Undocumented parameters. -!! \todo These module variables need to be documented as static/private variables or moved -!! into a control structure. ! Switches needed in import_stokes_drift -integer, parameter :: TESTPROF = 0, SURFBANDS = 1, & - DHH85 = 2, LF17 = 3, NULL_WaveMethod=-99, & - DATAOVR = 1, COUPLER = 2, INPUT = 3 - -! Options For Test Prof -Real :: TP_STKX0, TP_STKY0, TP_WVL -logical :: WaveAgePeakFreq ! Flag to use W -logical :: StaticWaves, DHH85_Is_Set -real :: WaveAge, WaveWind -real :: PI +!>@{ Enumeration values for the wave method +integer, parameter :: TESTPROF = 0, SURFBANDS = 1, DHH85 = 2, LF17 = 3, NULL_WaveMethod = -99 +!>@} +!>@{ Enumeration values for the wave data source +integer, parameter :: DATAOVR = 1, COUPLER = 2, INPUT = 3 !>@} contains @@ -200,9 +190,12 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) type(param_file_type), intent(in) :: param_file !< Input parameter structure type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic Pointer + ! Local variables - ! I/O - character*(13) :: TMPSTRING1,TMPSTRING2 + character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character*(13) :: TMPSTRING1, TMPSTRING2 character*(5), parameter :: NULL_STRING = "EMPTY" character*(12), parameter :: TESTPROF_STRING = "TEST_PROFILE" character*(13), parameter :: SURFBANDS_STRING = "SURFACE_BANDS" @@ -211,6 +204,8 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) character*(12), parameter :: DATAOVR_STRING = "DATAOVERRIDE" character*(7), parameter :: COUPLER_STRING = "COUPLER" character*(5), parameter :: INPUT_STRING = "INPUT" + logical :: use_waves + logical :: StatisticalWaves ! Dummy Check if (associated(CS)) then @@ -218,41 +213,61 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) return endif - PI=4.0*atan(1.0) + call get_param(param_file, mdl, "USE_WAVES", use_waves, & + "If true, enables surface wave modules.", default=.false.) + + ! Check if using LA_LI2016 + call get_param(param_file,mdl,"USE_LA_LI2016",StatisticalWaves, & + do_not_log=.true.,default=.false.) + + if (.not.(use_waves .or. StatisticalWaves)) return ! Allocate CS and set pointers allocate(CS) + CS%UseWaves = use_waves CS%diag => diag CS%Time => Time - ! Add any initializations needed here - dataOverrideIsInitialized = .false. + CS%g_Earth = US%L_to_Z**2*GV%g_Earth - ! The only way to get here is with UseWaves enabled. - CS%UseWaves=.true. + ! Add any initializations needed here + CS%DataOver_initialized = .false. call log_version(param_file, mdl, version) + ! Langmuir number Options + call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & + units="nondim", default=0.04) + + if (StatisticalWaves) then + CS%WaveMethod = LF17 + if (.not.use_waves) return + else + CS%WaveMethod = NULL_WaveMethod + end if + ! Wave modified physics ! Presently these are all in research mode call get_param(param_file, mdl, "LAGRANGIAN_MIXING", CS%LagrangianMixing, & "Flag to use Lagrangian Mixing of momentum", units="", & - Default=.false.) + Default=.false., do_not_log=.not.use_waves) if (CS%LagrangianMixing) then ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Lagrangian Mixing? Code not ready.") endif call get_param(param_file, mdl, "STOKES_MIXING", CS%StokesMixing, & "Flag to use Stokes Mixing of momentum", units="", & - Default=.false.) + Default=.false., do_not_log=.not.use_waves) if (CS%StokesMixing) then ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Stokes Mixing? Code not ready.") endif call get_param(param_file, mdl, "CORIOLIS_STOKES", CS%CoriolisStokes, & "Flag to use Coriolis Stokes acceleration", units="", & - Default=.false.) + Default=.false., do_not_log=.not.use_waves) if (CS%CoriolisStokes) then ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Coriolis-Stokes? Code not ready.") @@ -275,18 +290,19 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call MOM_error(FATAL, "wave_interface_init called with no specified "//& "WAVE_METHOD.") case (TESTPROF_STRING)! Test Profile - WaveMethod = TESTPROF - call get_param(param_file,mdl,"TP_STKX_SURF",TP_STKX0,& - 'Surface Stokes (x) for test profile',& - units='m/s',default=0.1) - call get_param(param_file,mdl,"TP_STKY_SURF",TP_STKY0,& - 'Surface Stokes (y) for test profile',& - units='m/s',default=0.0) - call get_param(param_file,mdl,"TP_WVL",TP_WVL,& + CS%WaveMethod = TESTPROF + call get_param(param_file, mdl, "TP_STKX_SURF", CS%TP_STKX0, & + 'Surface Stokes (x) for test profile', & + units='m/s', default=0.1, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "TP_STKY_SURF", CS%TP_STKY0, & + 'Surface Stokes (y) for test profile', & + units='m/s', default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file,mdl, "TP_WVL", CS%TP_WVL, & + 'Wavelength for test profile', & units='m', default=50.0, scale=US%m_to_Z) case (SURFBANDS_STRING)! Surface Stokes Drift Bands - WaveMethod = SURFBANDS - call get_param(param_file, mdl, "SURFBAND_SOURCE",TMPSTRING2, & + CS%WaveMethod = SURFBANDS + call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & "Choice of SURFACE_BANDS data mode, valid options include: \n"// & " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"// & " COUPLER - Look for variables from coupler pass \n"// & @@ -297,11 +313,11 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS"//& " but no SURFBAND_SOURCE.") case (DATAOVR_STRING)! Using Data Override - DataSource = DATAOVR - call get_param(param_file, mdl, "SURFBAND_FILENAME", SurfBandFileName, & + CS%DataSource = DATAOVR + call get_param(param_file, mdl, "SURFBAND_FILENAME", CS%SurfBandFileName, & "Filename of surface Stokes drift input band data.", default="StkSpec.nc") case (COUPLER_STRING)! Reserved for coupling - DataSource = Coupler + CS%DataSource = COUPLER ! This is just to make something work, but it needs to be read from the wavemodel. call get_param(param_file,mdl,"STK_BAND_COUPLER",CS%NumBands, & "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "// & @@ -313,9 +329,12 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) CS%WaveNum_Cen(:) = 0.0 CS%STKx0(:,:,:) = 0.0 CS%STKy0(:,:,:) = 0.0 - partitionmode = 0 + CS%PartitionMode = 0 + call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.", & + units='rad/m', default=0.12566, scale=US%Z_to_m) case (INPUT_STRING)! A method to input the Stokes band (globally uniform) - DataSource = Input + CS%DataSource = INPUT call get_param(param_file,mdl,"SURFBAND_NB",CS%NumBands, & "Prescribe number of wavenumber bands for Stokes drift. "// & "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "// & @@ -331,54 +350,50 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) CS%STKx0(:,:,:) = 0.0 allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:CS%NumBands)) CS%STKy0(:,:,:) = 0.0 - partitionmode=0 - call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",CS%WaveNum_Cen, & - "Central wavenumbers for surface Stokes drift bands.",units='rad/m', & - default=0.12566) - call get_param(param_file,mdl,"SURFBAND_STOKES_X",CS%PrescribedSurfStkX, & - "X-direction surface Stokes drift for bands.",units='m/s', & - default=0.15) - call get_param(param_file,mdl,"SURFBAND_STOKES_Y",CS%PrescribedSurfStkY, & - "Y-direction surface Stokes drift for bands.",units='m/s', & - default=0.0) + CS%PartitionMode = 0 + call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.", & + units='rad/m', default=0.12566, scale=US%Z_to_m) + call get_param(param_file, mdl, "SURFBAND_STOKES_X", CS%PrescribedSurfStkX, & + "X-direction surface Stokes drift for bands.", & + units='m/s', default=0.15, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "SURFBAND_STOKES_Y", CS%PrescribedSurfStkY, & + "Y-direction surface Stokes drift for bands.", & + units='m/s', default=0.0, scale=US%m_s_to_L_T) case default! No method provided call MOM_error(FATAL,'Check WAVE_METHOD.') end select - case (DHH85_STRING)!Donelan et al., 1985 spectrum - WaveMethod = DHH85 + case (DHH85_STRING) !Donelan et al., 1985 spectrum + CS%WaveMethod = DHH85 call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/"//& " Stokes drift in x-direction.") - call get_param(param_file,mdl,"DHH85_AGE_FP",WaveAgePeakFreq, & + call get_param(param_file, mdl, "DHH85_AGE_FP", CS%WaveAgePeakFreq, & "Choose true to use waveage in peak frequency.", & units='', default=.false.) - call get_param(param_file,mdl,"DHH85_AGE",WaveAge, & + call get_param(param_file, mdl, "DHH85_AGE", CS%WaveAge, & "Wave Age for DHH85 spectrum.", & units='', default=1.2) - call get_param(param_file,mdl,"DHH85_WIND",WaveWind, & + call get_param(param_file,mdl,"DHH85_WIND", CS%WaveWind, & "Wind speed for DHH85 spectrum.", & - units='', default=10.0) - call get_param(param_file,mdl,"STATIC_DHH85",StaticWaves, & + units='m s-1', default=10.0, scale=US%m_s_to_L_T) + call get_param(param_file,mdl,"STATIC_DHH85", CS%StaticWaves, & "Flag to disable updating DHH85 Stokes drift.", & default=.false.) case (LF17_STRING)!Li and Fox-Kemper 17 wind-sea Langmuir number - WaveMethod = LF17 + CS%WaveMethod = LF17 case default call MOM_error(FATAL,'Check WAVE_METHOD.') end select - ! Langmuir number Options - call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in "//& - "Langmuir number calculation, where La = sqrt(ust/Stokes).", & - units="nondim",default=0.04) - call get_param(param_file, mdl, "LA_MISALIGNMENT", LA_Misalignment, & - "Flag (logical) if using misalignment bt shear and waves in LA",& + ! Langmuir number Options (Note that CS%LA_FracHBL is set above.) + call get_param(param_file, mdl, "LA_MISALIGNMENT", CS%LA_Misalignment, & + "Flag (logical) if using misalignment bt shear and waves in LA", & default=.false.) call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & "A minimum value for all Langmuir numbers that is not physical, "//& "but is likely only encountered when the wind is very small and "//& - "therefore its effects should be mostly benign.",units="nondim",& + "therefore its effects should be mostly benign.", units="nondim", & default=0.05) ! Allocate and initialize @@ -405,53 +420,48 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Initialize Wave related outputs CS%id_surfacestokes_y = register_diag_field('ocean_model','surface_stokes_y', & - CS%diag%axesCu1,Time,'Surface Stokes drift (y)','m s-1') + CS%diag%axesCv1,Time,'Surface Stokes drift (y)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_surfacestokes_x = register_diag_field('ocean_model','surface_stokes_x', & - CS%diag%axesCv1,Time,'Surface Stokes drift (x)','m s-1') + CS%diag%axesCu1,Time,'Surface Stokes drift (x)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_3dstokes_y = register_diag_field('ocean_model','3d_stokes_y', & - CS%diag%axesCvL,Time,'3d Stokes drift (y)','m s-1') + CS%diag%axesCvL,Time,'3d Stokes drift (y)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_3dstokes_x = register_diag_field('ocean_model','3d_stokes_x', & - CS%diag%axesCuL,Time,'3d Stokes drift (y)','m s-1') - CS%id_La_turb = register_diag_field('ocean_model','La_turbulent',& + CS%diag%axesCuL,Time,'3d Stokes drift (x)', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_La_turb = register_diag_field('ocean_model','La_turbulent', & CS%diag%axesT1,Time,'Surface (turbulent) Langmuir number','nondim') - return end subroutine MOM_wave_interface_init -!> A 'lite' init subroutine to initialize a few inputs needed if using wave information -!! with the wind-speed dependent Stokes drift formulation of LF17 -subroutine MOM_wave_interface_init_lite(param_file) - type(param_file_type), intent(in) :: param_file !< Input parameter structure - character*(5), parameter :: NULL_STRING = "EMPTY" - character*(4), parameter :: LF17_STRING = "LF17" - character*(13) :: TMPSTRING1 - logical :: StatisticalWaves - - ! Langmuir number Options - call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in "//& - "Langmuir number calculation, where La = sqrt(ust/Stokes).", & - units="nondim",default=0.04) - - ! Check if using LA_LI2016 - call get_param(param_file,mdl,"USE_LA_LI2016",StatisticalWaves, & - do_not_log=.true.,default=.false.) - if (StatisticalWaves) then - WaveMethod = LF17 - PI=4.0*atan(1.0) - else - WaveMethod = NULL_WaveMethod - end if +!> This interface provides the caller with information from the waves control structure. +subroutine query_wave_properties(CS, NumBands, WaveNumbers, US) + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + integer, optional, intent(out) :: NumBands !< If present, this returns the number of + !!< wavenumber partitions in the wave discretization + real, dimension(:), optional, intent(out) :: Wavenumbers !< If present this returns the characteristic + !! wavenumbers of the wave discretization [m-1 or Z-1 ~> m-1] + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type that is used to undo + !! the dimensional scaling of the output variables, if present + integer :: n + + if (present(NumBands)) NumBands = CS%NumBands + if (present(Wavenumbers)) then + if (size(Wavenumbers) < CS%NumBands) call MOM_error(FATAL, "query_wave_properties called "//& + "with a Wavenumbers array that is smaller than the number of bands.") + if (present(US)) then + do n=1,CS%NumBands ; Wavenumbers(n) = US%m_to_Z * CS%WaveNum_Cen(n) ; enddo + else + do n=1,CS%NumBands ; Wavenumbers(n) = CS%WaveNum_Cen(n) ; enddo + endif + endif - return -end subroutine MOM_wave_interface_init_lite +end subroutine query_wave_properties !> Subroutine that handles updating of surface wave/Stokes drift related properties subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(time_type), intent(in) :: Day !< Current model time type(time_type), intent(in) :: dt !< Timestep as a time-type type(mech_forcing), intent(in), optional :: forces !< MOM_forcing_type @@ -462,40 +472,40 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) ! Computing central time of time step Day_Center = Day + DT/2 - if (WaveMethod == TESTPROF) then + if (CS%WaveMethod == TESTPROF) then ! Do nothing - elseif (WaveMethod==SURFBANDS) then - if (DataSource==DATAOVR) then + elseif (CS%WaveMethod == SURFBANDS) then + if (CS%DataSource == DATAOVR) then call Surface_Bands_by_data_override(day_center, G, GV, US, CS) - elseif (DataSource==Coupler) then + elseif (CS%DataSource == COUPLER) then if (.not.present(FORCES)) then call MOM_error(FATAL,"The option SURFBAND = COUPLER can not be used with "//& "this driver. If you are using a coupled driver with a wave model then "//& "check the arguments in the subroutine call to Update_Surface_Waves, "//& "otherwise select another option for SURFBAND_SOURCE.") endif - if (size(CS%WaveNum_Cen).ne.size(forces%stk_wavenumbers)) then + if (size(CS%WaveNum_Cen) /= size(forces%stk_wavenumbers)) then call MOM_error(FATAL, "Number of wavenumber bands in WW3 does not match that in MOM6. "//& "Make sure that STK_BAND_COUPLER in MOM6 input is equal to the number of bands in "//& "ww3_grid.inp, and that your mod_def.ww3 is up to date.") endif do b=1,CS%NumBands - CS%WaveNum_Cen(b) = forces%stk_wavenumbers(b) + CS%WaveNum_Cen(b) = US%Z_to_m * forces%stk_wavenumbers(b) !Interpolate from a grid to c grid do jj=G%jsc,G%jec do II=G%iscB,G%iecB - CS%STKx0(II,jj,b) = 0.5*(forces%UStkb(ii,jj,b)+forces%UStkb(ii+1,jj,b)) + CS%STKx0(II,jj,b) = US%m_s_to_L_T*0.5*(forces%UStkb(ii,jj,b)+forces%UStkb(ii+1,jj,b)) enddo enddo do JJ=G%jscB, G%jecB do ii=G%isc,G%iec - CS%STKY0(ii,JJ,b) = 0.5*(forces%VStkb(ii,jj,b)+forces%VStkb(ii,jj+1,b)) + CS%STKY0(ii,JJ,b) = US%m_s_to_L_T*0.5*(forces%VStkb(ii,jj,b)+forces%VStkb(ii,jj+1,b)) enddo enddo call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain) enddo - elseif (DataSource==Input) then + elseif (CS%DataSource == INPUT) then do b=1,CS%NumBands do jj=G%jsd,G%jed do II=G%isdB,G%iedB @@ -511,7 +521,6 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) endif endif - return end subroutine Update_Surface_Waves !> Constructs the Stokes Drift profile on the model grid based on @@ -526,10 +535,16 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ustar !< Wind friction velocity [Z T-1 ~> m s-1]. ! Local Variables - real :: Top, MidPoint, Bottom, one_cm, level_thick, min_level_thick_avg - real :: DecayScale - real :: CMN_FAC, WN, UStokes - real :: La + real :: Top, MidPoint, Bottom ! Positions within the layer [Z ~> m] + real :: one_cm ! One centimeter in the units of wavelengths [Z ~> m] + real :: level_thick ! The thickness of each layer [Z ~> m] + real :: min_level_thick_avg ! A minimum layer thickness for inclusion in the average [Z ~> m] + real :: DecayScale ! A vertical decay scale in the test profile [Z ~> m] + real :: CMN_FAC ! A nondimensional factor [nondim] + real :: WN ! Model wavenumber [Z-1 ~> m-1] + real :: UStokes ! A Stokes drift velocity [L T-1 ~> m s-1] + real :: PI ! 3.1415926535... + real :: La ! The local Langmuir number [nondim] integer :: ii, jj, kk, b, iim1, jjm1 one_cm = 0.01*US%m_to_Z @@ -537,8 +552,9 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) ! 1. If Test Profile Option is chosen ! Computing mid-point value from surface value and decay wavelength - if (WaveMethod==TESTPROF) then - DecayScale = 4.*PI / TP_WVL !4pi + if (CS%WaveMethod==TESTPROF) then + PI = 4.0*atan(1.0) + DecayScale = 4.*PI / CS%TP_WVL !4pi do jj = G%jsd,G%jed do II = G%isdB,G%iedB IIm1 = max(1,II-1) @@ -548,7 +564,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) Top = Bottom MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) Bottom = Bottom - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) - CS%Us_x(II,jj,kk) = TP_STKX0*exp(MidPoint*DecayScale) + CS%Us_x(II,jj,kk) = CS%TP_STKX0*exp(MidPoint*DecayScale) enddo enddo enddo @@ -561,14 +577,14 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) Top = Bottom MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - CS%Us_y(ii,JJ,kk) = TP_STKY0*exp(MidPoint*DecayScale) + CS%Us_y(ii,JJ,kk) = CS%TP_STKY0*exp(MidPoint*DecayScale) enddo enddo enddo ! 2. If Surface Bands is chosen ! In wavenumber mode compute integral for layer averaged Stokes drift. ! In frequency mode compuate value at midpoint. - elseif (WaveMethod==SURFBANDS) then + elseif (CS%WaveMethod==SURFBANDS) then CS%Us_x(:,:,:) = 0.0 CS%Us_y(:,:,:) = 0.0 CS%Us0_x(:,:) = 0.0 @@ -577,13 +593,16 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do jj = G%jsd,G%jed do II = G%isdB,G%iedB ! 1. First compute the surface Stokes drift - ! by integrating over the partitionas. + ! by integrating over the partitions. do b = 1,CS%NumBands - if (PartitionMode==0) then + if (CS%PartitionMode==0) then ! In wavenumber we are averaging over (small) level CMN_FAC = (1.0-exp(-one_cm*2.*CS%WaveNum_Cen(b))) / & (one_cm*2.*CS%WaveNum_Cen(b)) - elseif (PartitionMode==1) then + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = one_minus_exp_x(2.*CS%WaveNum_Cen(b)*one_cm) + ! or maybe just take the limit of vanishing thickness, CMN_FAC = 1.0 + elseif (CS%PartitionMode==1) then ! In frequency we are not averaging over level and taking top CMN_FAC = 1.0 endif @@ -595,24 +614,27 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) Top = Bottom IIm1 = max(II-1,1) level_thick = 0.5*GV%H_to_Z*(h(II,jj,kk)+h(IIm1,jj,kk)) - MidPoint = Bottom - 0.5*level_thick - Bottom = Bottom - level_thick + MidPoint = Top - 0.5*level_thick + Bottom = Top - level_thick ! -> Stokes drift in thin layers not averaged. if (level_thick>min_level_thick_avg) then do b = 1,CS%NumBands - if (PartitionMode==0) then - ! In wavenumber we are averaging over level + if (CS%PartitionMode==0) then + ! In wavenumber we are averaging over level CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - elseif (PartitionMode==1) then + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) + elseif (CS%PartitionMode==1) then if (CS%StkLevelMode==0) then ! Take the value at the midpoint - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then - ! divide by layer thickness - WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) !bgr bug-fix missing g + ! Use a numerical integration and then divide by layer thickness + WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) endif endif CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC @@ -620,10 +642,10 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) else ! Take the value at the midpoint do b = 1,CS%NumBands - if (PartitionMode==0) then - CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) - elseif (PartitionMode==1) then - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + if (CS%PartitionMode==0) then + CMN_FAC = exp(MidPoint * 2. * CS%WaveNum_Cen(b)) + elseif (CS%PartitionMode==1) then + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) endif CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC enddo @@ -636,11 +658,14 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do ii = G%isd,G%ied ! Compute the surface values. do b = 1,CS%NumBands - if (PartitionMode==0) then + if (CS%PartitionMode==0) then ! In wavenumber we are averaging over (small) level CMN_FAC = (1.0-exp(-one_cm*2.*CS%WaveNum_Cen(b))) / & (one_cm*2.*CS%WaveNum_Cen(b)) - elseif (PartitionMode==1) then + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = one_minus_exp_x(2.*CS%WaveNum_Cen(b)*one_cm) + ! or maybe just take the limit of vanishing thickness, CMN_FAC = 1.0 + elseif (CS%PartitionMode==1) then ! In frequency we are not averaging over level and taking top CMN_FAC = 1.0 endif @@ -652,24 +677,27 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) Top = Bottom JJm1 = max(JJ-1,1) level_thick = 0.5*GV%H_to_Z*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - MidPoint = Bottom - 0.5*level_thick - Bottom = Bottom - level_thick + MidPoint = Top - 0.5*level_thick + Bottom = Top - level_thick ! -> Stokes drift in thin layers not averaged. if (level_thick>min_level_thick_avg) then do b = 1,CS%NumBands - if (PartitionMode==0) then + if (CS%PartitionMode==0) then ! In wavenumber we are averaging over level CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - elseif (PartitionMode==1) then + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) + elseif (CS%PartitionMode==1) then if (CS%StkLevelMode==0) then ! Take the value at the midpoint - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then - ! divide by layer thickness - WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) !bgr bug-fix missing g + ! Use a numerical integration and then divide by layer thickness + WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) endif endif CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC @@ -677,10 +705,10 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) else ! Take the value at the midpoint do b = 1,CS%NumBands - if (PartitionMode==0) then + if (CS%PartitionMode==0) then CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) - elseif (PartitionMode==1) then - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + elseif (CS%PartitionMode==1) then + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) endif CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC enddo @@ -688,21 +716,21 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo enddo enddo - elseif (WaveMethod==DHH85) then - if (.not.(StaticWaves .and. DHH85_is_set)) then + elseif (CS%WaveMethod == DHH85) then + if (.not.(CS%StaticWaves .and. CS%DHH85_is_set)) then do jj = G%jsd,G%jed do II = G%isdB,G%iedB bottom = 0.0 do kk = 1,GV%ke Top = Bottom IIm1 = max(II-1,1) - MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) + MidPoint = Top - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) + Bottom = Top - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) !bgr note that this is using a u-point ii on h-point ustar ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non ! uniform cases. - call DHH85_mid(GV, US, MidPoint, UStokes) + call DHH85_mid(GV, US, CS, MidPoint, UStokes) ! Putting into x-direction (no option for direction CS%US_x(II,jj,kk) = UStokes enddo @@ -720,7 +748,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non ! uniform cases. - ! call DHH85_mid(GV, US, Midpoint, UStokes) + ! call DHH85_mid(GV, US, CS, Midpoint, UStokes) ! Putting into x-direction, so setting y direction to 0 CS%US_y(ii,JJ,kk) = 0.0 ! For rotational symmetry there should be the option for this to become = UStokes @@ -730,7 +758,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo enddo enddo - DHH85_is_set = .true. + CS%DHH85_is_set = .true. endif else! Keep this else, fallback to 0 Stokes drift do kk= 1,GV%ke @@ -773,6 +801,18 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) end subroutine Update_Stokes_Drift +!> Return the value of (1 - exp(-x))/x, using an accurate expression for small values of x. +real function one_minus_exp_x(x) + real, intent(in) :: x !< The argument of the function ((1 - exp(-x))/x) [nondim] + real, parameter :: C1_6 = 1.0/6.0 + if (abs(x) <= 2.0e-5) then + ! The Taylor series expression for exp(-x) gives a more accurate expression for 64-bit reals. + one_minus_exp_x = 1.0 - x * (0.5 - C1_6*x) + else + one_minus_exp_x = (1.0 - exp(-x)) / x + endif +end function one_minus_exp_x + !> A subroutine to fill the Stokes drift from a NetCDF file !! using the data_override procedures. subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) @@ -785,137 +825,81 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) ! Local variables real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal Stokes drift of band at h-points [m s-1] real :: temp_y(SZI_(G),SZJ_(G)) ! Psuedo-meridional Stokes drift of band at h-points [m s-1] - real :: Top, MidPoint - integer :: b - integer :: i, j - integer, dimension(4) :: start, counter, dims, dim_id - character(len=12) :: dim_name(4) - character(20) :: varname, varread1, varread2 - integer :: rcode_fr, rcode_wn, ncid, varid_fr, varid_wn, id, ndims - - if (.not.dataOverrideIsInitialized) then + integer, dimension(4) :: sizes ! The sizes of the various dimensions of the variable. + character(len=48) :: dim_name(4) ! The names of the dimensions of the variable. + character(len=20) :: varname ! The name of an input variable for data override. + real :: PI ! 3.1415926535... + logical :: wavenumber_exists + integer :: ndims, b, i, j + + if (.not.CS%DataOver_initialized) then call data_override_init(G%Domain) - dataOverrideIsInitialized = .true. - - ! Read in number of wavenumber bands in file to set number to be read in - ! Hardcoded filename/variables - varread1 = 'wavenumber' !Old method gives wavenumber - varread2 = 'frequency' !New method gives frequency - rcode_wn = NF90_OPEN(trim(SurfBandFileName), NF90_NOWRITE, ncid) - if (rcode_wn /= 0) then - call MOM_error(FATAL,"error opening file "//trim(SurfBandFileName)//& - " in MOM_wave_interface.") - endif + CS%DataOver_initialized = .true. - ! Check if rcode_wn or rcode_fr is 0 (checks if input has wavenumber or frequency) - rcode_wn = NF90_INQ_VARID(ncid, varread1, varid_wn) - rcode_fr = NF90_INQ_VARID(ncid, varread2, varid_fr) - - if (rcode_wn /= 0 .and. rcode_fr /= 0) then - call MOM_error(FATAL,"error finding variable "//trim(varread1)//& - " or "//trim(varread2)//" in file "//trim(SurfBandFileName)//" in MOM_wave_interface.") - - elseif (rcode_wn == 0) then - ! wavenumbers found: - PartitionMode = 0 - rcode_wn = NF90_INQUIRE_VARIABLE(ncid, varid_wn, ndims=ndims, & - dimids=dims) - if (rcode_wn /= 0) then - call MOM_error(FATAL, & - 'error inquiring dimensions MOM_wave_interface.') - endif - rcode_wn = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) - if (rcode_wn /= 0) then - call MOM_error(FATAL,"error reading dimension 1 data for "// & - trim(varread1)//" in file "// trim(SurfBandFileName)// & - " in MOM_wave_interface.") - endif - rcode_wn = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) - if (rcode_wn /= 0) then - call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& - " in file "//trim(SurfBandFileName)//" in MOM_wave_interace.") - endif - ! Allocating size of wavenumber bins - allocate( CS%WaveNum_Cen(1:id) ) - CS%WaveNum_Cen(:) = 0.0 - elseif (rcode_fr == 0) then - ! frequencies found: - PartitionMode = 1 - rcode_fr = NF90_INQUIRE_VARIABLE(ncid, varid_fr, ndims=ndims, & - dimids=dims) - if (rcode_fr /= 0) then - call MOM_error(FATAL,& - 'error inquiring dimensions MOM_wave_interface.') - endif - rcode_fr = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) - if (rcode_fr /= 0) then - call MOM_error(FATAL,"error reading dimension 1 data for "// & - trim(varread2)//" in file "// trim(SurfBandFileName)// & - " in MOM_wave_interface.") - endif - rcode_fr = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) - if (rcode_fr /= 0) then - call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& - " in file "//trim(SurfBandFileName)//" in MOM_wave_interace.") - endif - ! Allocating size of frequency bins - allocate( CS%Freq_Cen(1:id) ) - CS%Freq_Cen(:) = 0.0 - ! Allocating size of wavenumber bins - allocate( CS%WaveNum_Cen(1:id) ) - CS%WaveNum_Cen(:) = 0.0 - allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:id)) - CS%STKx0(:,:,:) = 0.0 - allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:id)) - CS%STKy0(:,:,:) = 0.0 + if (.not.file_exists(CS%SurfBandFileName)) & + call MOM_error(FATAL, "MOM_wave_interface is unable to find file "//trim(CS%SurfBandFileName)) + + ! Check if input has wavenumber or frequency variables. + + ! Read the number of wavenumber bands in the file, if the variable 'wavenumber' exists. + call get_var_sizes(CS%SurfBandFileName, 'wavenumber', ndims, sizes, dim_names=dim_name) + wavenumber_exists = (ndims > -1) + + if (.not.wavenumber_exists) then + ! Read the number of frequency bands in the file, if the variable 'frequency' exists. + call get_var_sizes(CS%SurfBandFileName, 'frequency', ndims, sizes, dim_names=dim_name) + if (ndims < 0) & + call MOM_error(FATAL, "error finding variable 'wavenumber' or 'frequency' in file "//& + trim(CS%SurfBandFileName)//" in MOM_wave_interface.") endif - ! Reading wavenumber bins/Frequencies - start(:) = 1 ! Set all start to 1 - counter(:) = 1 ! Set all counter to 1 - counter(1) = id ! Set counter(1) to id (number of frequency bins) - if (PartitionMode==0) then - rcode_wn = NF90_GET_VAR(ncid, dim_id(1), CS%WaveNum_Cen, start, counter) - if (rcode_wn /= 0) then - call MOM_error(FATAL,& - "error reading dimension 1 values for var_name "// & - trim(varread1)//",dim_name "//trim(dim_name(1))// & - " in file "// trim(SurfBandFileName)//" in MOM_wave_interface") - endif - CS%NUMBANDS = ID - do B = 1,CS%NumBands ; CS%WaveNum_Cen(b) = US%Z_to_m*CS%WaveNum_Cen(b) ; enddo - elseif (PartitionMode==1) then - rcode_fr = NF90_GET_VAR(ncid, dim_id(1), CS%Freq_Cen, start, counter) - if (rcode_fr /= 0) then - call MOM_error(FATAL,& - "error reading dimension 1 values for var_name "// & - trim(varread2)//",dim_name "//trim(dim_name(1))// & - " in file "// trim(SurfBandFileName)//" in MOM_wave_interface") - endif - CS%NUMBANDS = ID + CS%NUMBANDS = sizes(1) + ! Allocate the wavenumber bins + allocate( CS%WaveNum_Cen(CS%NUMBANDS) ) ; CS%WaveNum_Cen(:) = 0.0 + + if (wavenumber_exists) then + ! Wavenumbers found, so this file uses the old method: + CS%PartitionMode = 0 + + ! Reading wavenumber bins + call read_variable(CS%SurfBandFileName, dim_name(1), CS%WaveNum_Cen, scale=US%Z_to_m) + + else + ! Frequencies found, so this file uses the newer method: + CS%PartitionMode = 1 + + ! Allocate the frequency bins + allocate( CS%Freq_Cen(CS%NUMBANDS) ) ; CS%Freq_Cen(:) = 0.0 + + ! Reading frequencies + PI = 4.0*atan(1.0) + call read_variable(CS%SurfBandFileName, dim_name(1), CS%Freq_Cen, scale=2.*PI*US%T_to_s) + do B = 1,CS%NumBands - CS%WaveNum_Cen(b) = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) + CS%WaveNum_Cen(b) = CS%Freq_Cen(b)**2 / CS%g_Earth enddo endif - rcode_wn = NF90_close(ncid) - if (rcode_wn /= 0) call MOM_error(WARNING, & - "Error closing file "//trim(SurfBandFileName)//" in MOM_wave_interface.") - + if (.not.allocated(CS%STKx0)) then + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NUMBANDS) ) ; CS%STKx0(:,:,:) = 0.0 + endif + if (.not.allocated(CS%STKy0)) then + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,CS%NUMBANDS) ) ; CS%STKy0(:,:,:) = 0.0 + endif endif do b = 1,CS%NumBands temp_x(:,:) = 0.0 temp_y(:,:) = 0.0 varname = ' ' - write(varname,"(A3,I0)")'Usx',b - call data_override('OCN',trim(varname), temp_x, day_center) + write(varname, "(A3,I0)") 'Usx', b + call data_override('OCN', trim(varname), temp_x, day_center) varname = ' ' - write(varname,'(A3,I0)')'Usy',b - call data_override('OCN',trim(varname), temp_y, day_center) - ! Disperse into halo on h-grid + write(varname, "(A3,I0)") 'Usy', b + call data_override('OCN', trim(varname), temp_y, day_center) + ! Update halo on h-grid call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) - !Filter land values + ! Filter land values do j = G%jsd,G%jed do i = G%Isd,G%Ied if (abs(temp_x(i,j)) > 10. .or. abs(temp_y(i,j)) > 10.) then @@ -929,18 +913,19 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) ! Interpolate to u/v grids do j = G%jsc,G%jec do I = G%IscB,G%IecB - CS%STKx0(I,j,b) = 0.5 * (temp_x(i,j) + temp_x(i+1,j)) + CS%STKx0(I,j,b) = 0.5 * US%m_s_to_L_T*(temp_x(i,j) + temp_x(i+1,j)) enddo enddo do J = G%JscB,G%JecB do i = G%isc,G%iec - CS%STKy0(i,J,b) = 0.5 * (temp_y(i,j) + temp_y(i,j+1)) + CS%STKy0(i,J,b) = 0.5 * US%m_s_to_L_T*(temp_y(i,j) + temp_y(i,j+1)) enddo enddo - ! Disperse into halo on u/v grids - call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain, To_ALL) enddo !Closes b-loop + ! Update halo on u/v grids + call pass_vector(CS%STKx0(:,:,:), CS%STKy0(:,:,:), G%Domain, To_ALL) + end subroutine Surface_Bands_by_data_override !> Interface to get Langmuir number based on options stored in wave structure @@ -964,28 +949,30 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & real, dimension(SZK_(GV)), optional, & intent(in) :: H !< Grid layer thickness [H ~> m or kg m-2] real, dimension(SZK_(GV)), optional, & - intent(in) :: U_H !< Zonal velocity at H point [m s-1] + intent(in) :: U_H !< Zonal velocity at H point [L T-1 ~> m s-1] or [m s-1] real, dimension(SZK_(GV)), optional, & - intent(in) :: V_H !< Meridional velocity at H point [m s-1] + intent(in) :: V_H !< Meridional velocity at H point [L T-1 ~> m s-1] or [m s-1] type(Wave_parameters_CS), & pointer :: Waves !< Surface wave control structure. - real, intent(out) :: LA !< Langmuir number + real, intent(out) :: LA !< Langmuir number [nondim] !Local Variables - real :: Top, bottom, midpoint - real :: Dpt_LASL, ShearDirection, WaveDirection - real :: LA_STKx, LA_STKy, LA_STK ! Stokes velocities in [m s-1] + real :: Top, bottom, midpoint ! Positions within each layer [Z ~> m] + real :: Dpt_LASL ! Averaging depth for Stokes drift [Z ~> m] + real :: ShearDirection ! Shear angular direction from atan2 [radians] + real :: WaveDirection ! Wave angular direction from atan2 [radians] + real :: LA_STKx, LA_STKy, LA_STK ! Stokes velocities in [L T-1 ~> m s-1] logical :: ContinueLoop, USE_MA - real, dimension(SZK_(GV)) :: US_H, VS_H - real, allocatable :: StkBand_X(:), StkBand_Y(:) + real, dimension(SZK_(GV)) :: US_H, VS_H ! Profiles of Stokes velocities [L T-1 ~> m s-1] + real, allocatable :: StkBand_X(:), StkBand_Y(:) ! Stokes drifts by band [L T-1 ~> m s-1] integer :: KK, BB ! Compute averaging depth for Stokes drift (negative) - Dpt_LASL = min(-0.1*US%m_to_Z, -LA_FracHBL*HBL) + Dpt_LASL = min(-0.1*US%m_to_Z, -Waves%LA_FracHBL*HBL) - USE_MA = LA_Misalignment + USE_MA = Waves%LA_Misalignment if (present(Override_MA)) USE_MA = Override_MA ! If requesting to use misalignment in the Langmuir number compute the Shear Direction @@ -1006,7 +993,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & enddo endif - if (WaveMethod==TESTPROF) then + if (Waves%WaveMethod==TESTPROF) then do kk = 1,GV%ke US_H(kk) = 0.5*(WAVES%US_X(I,j,kk)+WAVES%US_X(I-1,j,kk)) VS_H(kk) = 0.5*(WAVES%US_Y(i,J,kk)+WAVES%US_Y(i,J-1,kk)) @@ -1014,7 +1001,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & call Get_SL_Average_Prof( GV, Dpt_LASL, H, US_H, LA_STKx) call Get_SL_Average_Prof( GV, Dpt_LASL, H, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX*LA_STKX+LA_STKY*LA_STKY) - elseif (WaveMethod==SURFBANDS) then + elseif (Waves%WaveMethod==SURFBANDS) then allocate(StkBand_X(WAVES%NumBands), StkBand_Y(WAVES%NumBands)) do bb = 1,WAVES%NumBands StkBand_X(bb) = 0.5*(WAVES%STKx0(I,j,bb)+WAVES%STKx0(I-1,j,bb)) @@ -1024,7 +1011,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & call Get_SL_Average_Band(GV, Dpt_LASL, WAVES%NumBands, WAVES%WaveNum_Cen, StkBand_Y, LA_STKy ) LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) deallocate(StkBand_X, StkBand_Y) - elseif (WaveMethod==DHH85) then + elseif (Waves%WaveMethod==DHH85) then ! Temporarily integrating profile rather than spectrum for simplicity do kk = 1,GV%ke US_H(kk) = 0.5*(WAVES%US_X(I,j,kk)+WAVES%US_X(I-1,j,kk)) @@ -1033,23 +1020,23 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & call Get_SL_Average_Prof( GV, Dpt_LASL, H, US_H, LA_STKx) call Get_SL_Average_Prof( GV, Dpt_LASL, H, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) - elseif (WaveMethod==LF17) then - call get_StokesSL_LiFoxKemper(ustar, hbl*LA_FracHBL, GV, US, LA_STK, LA) - elseif (WaveMethod==Null_WaveMethod) then + elseif (Waves%WaveMethod==LF17) then + call get_StokesSL_LiFoxKemper(ustar, hbl*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA) + elseif (Waves%WaveMethod==Null_WaveMethod) then call MOM_error(FATAL, "Get_Langmuir_number called without defining a WaveMethod. "//& "Suggest to make sure USE_LT is set/overridden to False or "//& "choose a wave method (or set USE_LA_LI2016 to use statistical "//& "waves.") endif - if (.not.(WaveMethod==LF17)) then + if (.not.(Waves%WaveMethod==LF17)) then ! This is an arbitrary lower bound on Langmuir number. ! We shouldn't expect values lower than this, but ! there is also no good reason to cap it here other then ! to prevent large enhancements in unconstrained parts of ! the curve fit parameterizations. ! Note the dimensional constant background Stokes velocity of 10^-10 m s-1. - LA = max(WAVES%La_min, sqrt(US%Z_to_m*US%s_to_T*ustar / (LA_STK+1.e-10))) + LA = max(WAVES%La_min, sqrt(US%Z_to_L*ustar / (LA_STK + 1.e-10*US%m_s_to_L_T))) endif if (Use_MA) then @@ -1057,7 +1044,6 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & LA = LA / sqrt(max(1.e-8, cos( WaveDirection - ShearDirection))) endif - return end subroutine get_Langmuir_Number !> Get SL averaged Stokes drift from Li/FK 17 method @@ -1076,44 +1062,58 @@ end subroutine get_Langmuir_Number !! - BGR change output to LA from Efactor !! - BGR remove u10 input !! - BGR note: fixed parameter values should be changed to "get_params" -subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) +subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) real, intent(in) :: ustar !< water-side surface friction velocity [Z T-1 ~> m s-1]. real, intent(in) :: hbl !< boundary layer depth [Z ~> m]. type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(out) :: UStokes_SL !< Surface layer averaged Stokes drift [m s-1] + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + real, intent(out) :: UStokes_SL !< Surface layer averaged Stokes drift [L T-1 ~> m s-1] real, intent(out) :: LA !< Langmuir number ! Local variables ! parameters real, parameter :: & - ! ratio of U19.5 to U10 (Holthuijsen, 2007) + ! ratio of U19.5 to U10 (Holthuijsen, 2007) [nondim] u19p5_to_u10 = 1.075, & ! ratio of mean frequency to peak frequency for - ! Pierson-Moskowitz spectrum (Webb, 2011) + ! Pierson-Moskowitz spectrum (Webb, 2011) [nondim] fm_into_fp = 1.296, & - ! ratio of surface Stokes drift to U10 + ! ratio of surface Stokes drift to U10 [nondim] us_to_u10 = 0.0162, & - ! loss ratio of Stokes transport + ! loss ratio of Stokes transport [nondim] r_loss = 0.667 - real :: UStokes, hm0, fm, fp, vstokes, kphil, kstar - real :: z0, z0i, r1, r2, r3, r4, tmp, lasl_sqr_i - real :: u10 - + real :: UStokes ! The surface Stokes drift [L T-1 ~> m s-1] + real :: hm0 ! The significant wave height [Z ~> m] + real :: fm ! The mean wave frequency [T-1 ~> s-1] + real :: fp ! The peak wave frequency [T-1 ~> s-1] + real :: kphil ! A peak wavenumber in the Phillips spectrum [Z-1 ~> m-1] + real :: kstar ! A rescaled wavenumber? [Z-1 ~> m-1] + real :: vstokes ! The total Stokes transport [Z L T-1 ~> m2 s-1] + real :: z0 ! The boundary layer depth [Z ~> m] + real :: z0i ! The inverse of theboundary layer depth [Z-1 ~> m-1] + real :: r1, r2, r3, r4 ! Nondimensional ratios [nondim] + real :: r5 ! A single expression that combines r3 and r4 [nondim] + real :: root_2kz ! The square root of twice the peak wavenumber times the + ! boundary layer depth [nondim] + real :: u10 ! The 10 m wind speed [L T-1 ~> m s-1] + real :: PI ! 3.1415926535... + + PI = 4.0*atan(1.0) UStokes_sl = 0.0 - LA=1.e8 + LA = 1.e8 if (ustar > 0.0) then + ! This code should be revised to minimize the number of divisions and cancel out common factors. + ! Computing u10 based on u_star and COARE 3.5 relationships - call ust_2_u10_coare3p5(US%Z_to_m*US%s_to_T*ustar*sqrt(US%R_to_kg_m3*GV%Rho0/1.225), u10, GV, US) + call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/(1.225*US%kg_m3_to_R)), u10, GV, US, CS) ! surface Stokes drift UStokes = us_to_u10*u10 ! - ! significant wave height from Pierson-Moskowitz - ! spectrum (Bouws, 1998) - hm0 = 0.0246 *u10**2 + ! significant wave height from Pierson-Moskowitz spectrum (Bouws, 1998) + hm0 = 0.0246*US%m_to_Z*US%L_T_to_m_s**2 * u10**2 ! ! peak frequency (PM, Bouws, 1998) - tmp = 2.0 * PI * u19p5_to_u10 * u10 - fp = 0.877 * US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / tmp + fp = 0.877 * (US%L_to_Z*GV%g_Earth) / (2.0 * PI * u19p5_to_u10 * u10) ! ! mean frequency fm = fm_into_fp * fp @@ -1122,22 +1122,29 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) ! for the effect of directional spreading, multidirectional waves ! and the use of PM peak frequency and PM significant wave height ! on estimating the Stokes transport) - vstokes = 0.125 * PI * r_loss * fm * hm0**2 + vstokes = 0.125 * PI * r_loss * US%Z_to_L * fm * hm0**2 ! ! the general peak wavenumber for Phillips' spectrum ! (Breivik et al., 2016) with correction of directional spreading kphil = 0.176 * UStokes / vstokes ! - ! surface layer averaged Stokes dirft with Stokes drift profile + ! surface layer averaged Stokes drift with Stokes drift profile ! estimated from Phillips' spectrum (Breivik et al., 2016) ! the directional spreading effect from Webb and Fox-Kemper, 2015 ! is also included kstar = kphil * 2.56 ! surface layer - z0 = abs(US%Z_to_m*hbl) + z0 = abs(hbl) z0i = 1.0 / z0 - ! term 1 to 4 - r1 = ( 0.151 / kphil * z0i -0.84 ) * & + + ! Combining all of the expressions above gives kPhil as the following + ! where the first two lines are just a constant: + ! kPhil = ((0.176 * us_to_u10 * u19p5_to_u10) / & + ! (0.5*0.125 * r_loss * fm_into_fp * 0.877 * 0.0246**2)) * & + ! (US%T_to_s*US%m_s_to_L_T)**2 / (CS%g_Earth * u10**2) + + ! Terms 1 to 4, as written in the appendix of Li et al. (2017) + r1 = ( 0.151 / kphil * z0i - 0.84 ) * & ( 1.0 - exp(-2.0 * kphil * z0) ) r2 = -( 0.84 + 0.0591 / kphil * z0i ) * & sqrt( 2.0 * PI * kphil * z0 ) * & @@ -1145,10 +1152,34 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) r3 = ( 0.0632 / kstar * z0i + 0.125 ) * & (1.0 - exp(-2.0 * kstar * z0) ) r4 = ( 0.125 + 0.0946 / kstar * z0i ) * & - sqrt( 2.0 * PI *kstar * z0) * & + sqrt( 2.0 * PI * kstar * z0) * & erfc( sqrt( 2.0 * kstar * z0 ) ) UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) - if(UStokes_sl .ne. 0.0)LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) + + ! The following is equivalent to the code above, but avoids singularities +! r1 = ( 0.302 - 1.68*kphil*z0 ) * one_minus_exp_x(2.0*kphil * z0) +! r3 = ( 0.1264 + 0.64*kphil*z0 ) * one_minus_exp_x(5.12*kphil * z0) +! root_2kz = sqrt(2.0 * kphil * z0) +! ! r2 = -( 0.84 + 0.0591*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( root_2kz ) +! ! r4 = ( 0.2 + 0.059125*2.0 / (root_2kz**2) ) * sqrt(PI)* root_2kz * erfc( 1.6 * root_2kz ) +! +! ! r5 = r2 + r4 (with a small correction to one coefficient to avoid a singularity when z0 = 0): +! ! The correction leads to <1% relative differences in (r2+r4) for root_2kz > 0.05, but without +! ! it the values of r2 + r4 are qualitatively wrong (>50% errors) for root_2kz < 0.0015 . +! ! It has been verified that these two expressions for r5 are the same to 6 decimal places for +! ! root_2kz between 1e-10 and 1e-3, but that the first one degrades for smaller values. +! if (root_2kz > 1e-3) then +! r5 = sqrt(PI) * (root_2kz * (-0.84 * erfc(root_2kz) + 0.2 * erfc(1.6*root_2kz)) + & +! 0.1182 * (erfc(1.6*root_2kz) - erfc(root_2kz)) / root_2kz) +! else +! ! It is more accurate to replace erf with the first two terms of its Taylor series +! ! erf(z) = (2/sqrt(pi)) * z * (1. - (1/3)*z**2 + (1/10)*z**4 - (1/42)*z**6 + ...) +! ! and then cancel or combine common terms and drop negligibly small terms. +! r5 = -0.64*sqrt(PI)*root_2kz + (-0.14184 + 1.0839648 * root_2kz**2) +! endif +! UStokes_sl = UStokes * (0.715 + ((r1 + r2) + r5)) + + if (UStokes_sl /= 0.0) LA = sqrt(US%Z_to_L*ustar / UStokes_sl) endif end subroutine Get_StokesSL_LiFoxKemper @@ -1209,8 +1240,8 @@ subroutine Get_SL_Average_Band( GV, AvgDepth, NB, WaveNumbers, SurfStokes, Avera real, dimension(NB), & intent(in) :: WaveNumbers !< Wavenumber corresponding to each band [Z-1 ~> m-1] real, dimension(NB), & - intent(in) :: SurfStokes !< Surface Stokes drift for each band [m s-1] - real, intent(out) :: Average !< Output average Stokes drift over depth AvgDepth [m s-1] + intent(in) :: SurfStokes !< Surface Stokes drift for each band [L T-1 ~> m s-1] + real, intent(out) :: Average !< Output average Stokes drift over depth AvgDepth [L T-1 ~> m s-1] ! Local variables integer :: bb @@ -1223,9 +1254,11 @@ subroutine Get_SL_Average_Band( GV, AvgDepth, NB, WaveNumbers, SurfStokes, Avera Average = Average + SurfStokes(BB) * & (1.-EXP(-abs(AvgDepth * 2.0 * WaveNumbers(BB)))) / & abs(AvgDepth * 2.0 * WaveNumbers(BB)) + + ! For accuracy when AvgDepth is small change the above to: + ! Average = Average + SurfStokes(BB) * one_minus_exp_x(abs(AvgDepth * 2.0 * WaveNumbers(BB))) enddo - return end subroutine Get_SL_Average_Band !> Compute the Stokes drift at a given depth @@ -1234,42 +1267,49 @@ end subroutine Get_SL_Average_Band !! use for comparing MOM6 simulation to his LES !! computed at z mid point (I think) and not depth averaged. !! Should be fine to integrate in frequency from 0.1 to sqrt(-0.2*grav*2pi/dz -subroutine DHH85_mid(GV, US, zpt, UStokes) +subroutine DHH85_mid(GV, US, CS, zpt, UStokes) type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure real, intent(in) :: zpt !< Depth to get Stokes drift [Z ~> m]. - real, intent(out) :: UStokes !< Stokes drift [m s-1] + real, intent(out) :: UStokes !< Stokes drift [L T-1 ~> m s-1] ! - real :: ann, Bnn, Snn, Cnn, Dnn - real :: omega_peak, omega, u10, WA, domega - real :: omega_min, omega_max, wavespec, Stokes - real :: g_Earth ! Gravitational acceleration [m s-2] - integer :: Nomega, OI - - WA = WaveAge - u10 = WaveWind - g_Earth = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth + real :: ann, Bnn, Snn, Cnn, Dnn ! Nondimensional factors [nondim] + real :: omega_peak ! The peak wave frequency [T-1 ~> s-1] + real :: omega ! The average frequency in the band [T-1 ~> s-1] + real :: domega ! The width in frequency of the band [T-1 ~> s-1] + real :: omega_min ! The minimum wave frequency [T-1 ~> s-1] + real :: omega_max ! The maximum wave frequency [T-1 ~> s-1] + real :: u10 ! The wind speed for this spectrum [Z T-1 ~> m s-1] + real :: wavespec ! The wave spectrum [L Z T ~> m2 s] + real :: Stokes ! The Stokes displacement per cycle [L ~> m] + real :: PI ! 3.1415926535... + integer :: Nomega ! The number of wavenumber bands + integer :: OI + + u10 = CS%WaveWind*US%L_to_Z !/ - omega_min = 0.1 ! Hz + omega_min = 0.1*US%T_to_s ! Hz ! Cut off at 30cm for now... - omega_max = 10. ! ~sqrt(0.2*g_Earth*2*pi/0.3) + omega_max = 10.*US%T_to_s ! ~sqrt(0.2*g_Earth*2*pi/0.3) NOmega = 1000 domega = (omega_max-omega_min)/real(NOmega) ! - if (WaveAgePeakFreq) then - omega_peak = g_Earth / (WA * u10) + if (CS%WaveAgePeakFreq) then + omega_peak = CS%g_Earth / (CS%WaveAge * u10) else - omega_peak = 2. * pi * 0.13 * g_Earth / U10 + PI = 4.0*atan(1.0) + omega_peak = 2. * PI * 0.13 * CS%g_Earth / u10 endif !/ - Ann = 0.006 * WaveAge**(-0.55) + Ann = 0.006 * CS%WaveAge**(-0.55) Bnn = 1.0 - Snn = 0.08 * (1.0 + 4.0 * WaveAge**3) + Snn = 0.08 * (1.0 + 4.0 * CS%WaveAge**3) Cnn = 1.7 - if (WA < 1.) then - Cnn = Cnn - 6.0*log10(WA) + if (CS%WaveAge < 1.) then + Cnn = Cnn - 6.0*log10(CS%WaveAge) endif !/ UStokes = 0.0 @@ -1277,16 +1317,15 @@ subroutine DHH85_mid(GV, US, zpt, UStokes) do oi = 1,nomega-1 Dnn = exp ( -0.5 * (omega-omega_peak)**2 / (Snn**2 * omega_peak**2) ) ! wavespec units = m2s - wavespec = (Ann * g_Earth**2 / (omega_peak*omega**4 ) ) * & + wavespec = US%Z_to_L * (Ann * CS%g_Earth**2 / (omega_peak*omega**4 ) ) * & exp(-bnn*(omega_peak/omega)**4)*Cnn**Dnn ! Stokes units m (multiply by frequency range for units of m/s) Stokes = 2.0 * wavespec * omega**3 * & - exp( 2.0 * omega**2 * US%Z_to_m*zpt / g_Earth) / g_Earth + exp( 2.0 * omega**2 * zpt / CS%g_Earth) / CS%g_Earth UStokes = UStokes + Stokes*domega omega = omega + domega enddo - return end subroutine DHH85_mid !> Explicit solver for Stokes mixing. @@ -1300,13 +1339,13 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: u !< Velocity i-component [m s-1] + intent(inout) :: u !< Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: v !< Velocity j-component [m s-1] + intent(inout) :: v !< Velocity j-component [L T-1 ~> m s-1] type(Wave_parameters_CS), & pointer :: Waves !< Surface wave related control structure. ! Local variables - real :: dTauUp, dTauDn ! Vertical momentum fluxes [Z T-1 m s-1] + real :: dTauUp, dTauDn ! Vertical momentum fluxes [Z L T-2 ~> m2 s-2] real :: h_Lay ! The layer thickness at a velocity point [Z ~> m]. integer :: i,j,k @@ -1359,23 +1398,23 @@ end subroutine StokesMixing !! CHECK THAT RIGHT TIMESTEP IS PASSED IF YOU USE THIS** !! !! Not accessed in the standard code. -subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES, US) +subroutine CoriolisStokes(G, GV, dt, h, u, v, WAVES, US) type(ocean_grid_type), & intent(in) :: G !< Ocean grid type(verticalGrid_type), & intent(in) :: GV !< Ocean vertical grid - real, intent(in) :: Dt !< Time step of MOM6 [s] CHECK IF PASSING RIGHT TIMESTEP + real, intent(in) :: dt !< Time step of MOM6 [T ~> s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: u !< Velocity i-component [m s-1] + intent(inout) :: u !< Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: v !< Velocity j-component [m s-1] + intent(inout) :: v !< Velocity j-component [L T-1 ~> m s-1] type(Wave_parameters_CS), & pointer :: Waves !< Surface wave related control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: DVel ! A rescaled velocity change [m s-1 T-1 ~> m s-2] + real :: DVel ! A rescaled velocity change [L T-2 ~> m s-2] integer :: i,j,k do k = 1, GV%ke @@ -1383,7 +1422,7 @@ subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES, US) do I = G%iscB, G%iecB DVel = 0.25*(WAVES%us_y(i,j+1,k)+WAVES%us_y(i-1,j+1,k))*G%CoriolisBu(i,j+1) + & 0.25*(WAVES%us_y(i,j,k)+WAVES%us_y(i-1,j,k))*G%CoriolisBu(i,j) - u(I,j,k) = u(I,j,k) + DVEL*US%s_to_T*DT + u(I,j,k) = u(I,j,k) + DVEL*dt enddo enddo enddo @@ -1393,7 +1432,7 @@ subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES, US) do i = G%isc, G%iec DVel = 0.25*(WAVES%us_x(i+1,j,k)+WAVES%us_x(i+1,j-1,k))*G%CoriolisBu(i+1,j) + & 0.25*(WAVES%us_x(i,j,k)+WAVES%us_x(i,j-1,k))*G%CoriolisBu(i,j) - v(i,J,k) = v(i,j,k) - DVEL*US%s_to_T*DT + v(i,J,k) = v(i,j,k) - DVEL*dt enddo enddo enddo @@ -1403,16 +1442,20 @@ end subroutine CoriolisStokes !! Probably doesn't belong in this module, but it is used here to estimate !! wind speed for wind-wave relationships. Should be a fine way to estimate !! the neutral wind-speed as written here. -subroutine ust_2_u10_coare3p5(USTair, U10, GV, US) - real, intent(in) :: USTair !< Wind friction velocity [m s-1] - real, intent(out) :: U10 !< 10-m neutral wind speed [m s-1] +subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) + real, intent(in) :: USTair !< Wind friction velocity [Z T-1 ~> m s-1] + real, intent(out) :: U10 !< 10-m neutral wind speed [L T-1 ~> m s-1] type(verticalGrid_type), intent(in) :: GV !< vertical grid type type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure ! Local variables real, parameter :: vonkar = 0.4 ! Should access a get_param von karman - real, parameter :: nu=1e-6 ! Should access a get_param air-viscosity - real :: z0sm, z0, z0rough, u10a, alpha, CD + real :: nu ! The viscosity of air [Z2 T-1 ~> m2 s-1] + real :: z0sm, z0, z0rough ! Roughness lengths [Z ~> m] + real :: u10a ! The previous guess for u10 [L T-1 ~> m s-1] + real :: alpha ! A nondimensional factor in a parameterization [nondim] + real :: CD ! The drag coefficient [nondim] integer :: CT ! Uses empirical formula for z0 to convert ustar_air to u10 based on the @@ -1421,31 +1464,34 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US) ! Note in Edson et al. 2013, eq. 13 m is given as 0.017. However, ! m=0.0017 reproduces the curve in their figure 6. - z0sm = 0.11 * nu * US%m_to_Z / USTair !Compute z0smooth from ustar guess - u10 = USTair/sqrt(0.001) !Guess for u10 - u10a = 1000 + nu = 1.0e-6*US%m2_s_to_Z2_T ! Should access a get_param for air-viscosity + + z0sm = 0.11 * nu / USTair ! Compute z0smooth from ustar guess + u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 + ! For efficiency change the line above to USTair * sqrt(1000.0) or USTair * 31.6227766 . + u10a = 1000.0*US%m_s_to_L_T ! An insanely large upper bound for u10. CT=0 - do while (abs(u10a/u10-1.) > 0.001) + do while (abs(u10a/u10 - 1.) > 0.001) ! Change this to (abs(u10a - u10) > 0.001*u10) for efficiency. CT=CT+1 u10a = u10 - alpha = min(0.028, 0.0017 * u10 - 0.005) - z0rough = alpha * (US%m_s_to_L_T*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess + alpha = min(0.028, 0.0017*US%L_T_to_m_s * u10 - 0.005) + z0rough = alpha * (US%Z_to_L*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess z0 = z0sm + z0rough CD = ( vonkar / log(10.*US%m_to_Z / z0) )**2 ! Compute CD from derived roughness - u10 = USTair/sqrt(CD) ! Compute new u10 from derived CD, while loop + u10 = US%Z_to_L*USTair/sqrt(CD) ! Compute new u10 from derived CD, while loop ! ends and checks for convergence...CT counter ! makes sure loop doesn't run away if function ! doesn't converge. This code was produced offline ! and converged rapidly (e.g. 2 cycles) ! for ustar=0.0001:0.0001:10. if (CT>20) then - u10 = USTair/sqrt(0.0015) ! I don't expect to get here, but just + u10 = US%Z_to_L*USTair/sqrt(0.0015) ! I don't expect to get here, but just ! in case it will output a reasonable value. exit endif enddo - return + end subroutine ust_2_u10_coare3p5 !> Clear pointers, deallocate memory @@ -1466,7 +1512,6 @@ subroutine Waves_end(CS) deallocate( CS ) - return end subroutine Waves_end !> \namespace mom_wave_interface diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 8f5c6d283e..dfa9c19460 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -55,8 +55,10 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par real :: half_strat ! The fractional depth where the stratification is centered [nondim] real :: half_depth ! The depth where the stratification is centered [Z ~> m] logical :: just_read ! If true, just read parameters but set nothing. + logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_thickness" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -76,6 +78,10 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.not.just_read, do_not_log=just_read) + ! If re-entrant in the Y direction, we use a sine function instead of a + ! tanh. The ratio len_lat/jet_width should be an integer in this case. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & + default=.false., do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -85,6 +91,7 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par do k=2+nz/2,nz+1 eta0(k) = -G%max_depth - 2.0*(G%max_depth-half_depth) * ((k-(nz+1))/real(nz)) enddo + pi = 4.0*atan(1.0) do j=js,je eta_im(j,1) = 0.0 ; eta_im(j,nz+1) = -G%max_depth @@ -93,6 +100,10 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par y_2 = G%geoLatT(is,j) - G%south_lat - 0.5*G%len_lat eta_im(j,K) = eta0(k) + jet_height * tanh(y_2 / jet_width) ! or ... + jet_height * atan(y_2 / jet_width) + if (reentrant_y) then + y_2 = 2.*pi*y_2 + eta_im(j,K) = eta0(k) + jet_height * sin(y_2 / jet_width) + endif if (eta_im(j,K) > 0.0) eta_im(j,K) = 0.0 if (eta_im(j,K) < -G%max_depth) eta_im(j,K) = -G%max_depth enddo ; enddo @@ -138,6 +149,7 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] integer :: i, j, k, is, ie, js, je, nz, m logical :: just_read ! If true, just read parameters but set nothing. + logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_velocity" ! This subroutine's name. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -154,6 +166,10 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.not.just_read, do_not_log=just_read) + ! If re-entrant in the Y direction, we use a sine function instead of a + ! tanh. The ratio len_lat/jet_width should be an integer in this case. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & + default=.false., do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -165,14 +181,20 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p ! Use thermal wind shear to give a geostrophically balanced flow. do k=nz-1,1 ; do j=js,je ; do I=is-1,ie y_2 = G%geoLatCu(I,j) - G%south_lat - 0.5*G%len_lat + if (reentrant_y) then + y_2 = 2.*pi*y_2 + u(I,j,k) = u(I,j,k+1) + (1.e-3 * (jet_height / (US%m_to_L*jet_width)) * & + cos(y_2/jet_width) ) + else ! This uses d/d y_2 atan(y_2 / jet_width) ! u(I,j,k) = u(I,j,k+1) + ( jet_height / & ! (1.0e3*US%m_to_L*jet_width * (1.0 + (y_2 / jet_width)**2))) * & ! (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) ! This uses d/d y_2 tanh(y_2 / jet_width) - u(I,j,k) = u(I,j,k+1) + (1e-3 * (jet_height / (US%m_to_L*jet_width)) * & + u(I,j,k) = u(I,j,k+1) + (1e-3 * (jet_height / (US%m_to_L*jet_width)) * & (sech(y_2 / jet_width))**2 ) * & (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) + endif enddo ; enddo ; enddo do k=1,nz ; do j=js,je ; do I=is-1,ie @@ -228,6 +250,8 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) real :: y_2 ! The y-position relative to the channel center, in km. real :: half_strat ! The fractional depth where the straficiation is centered [nondim]. real :: half_depth ! The depth where the stratification is centered [Z ~> m]. + real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] + logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_sponges" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -255,6 +279,10 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.true.) + ! If re-entrant in the Y direction, we use a sine function instead of a + ! tanh. The ratio len_lat/jet_width should be an integer in this case. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & + default=.false., do_not_log=.true.) half_depth = G%max_depth*half_strat eta0(1) = 0.0 ; eta0(nz+1) = -G%max_depth @@ -262,6 +290,7 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) do k=2+nz/2,nz+1 eta0(k) = -G%max_depth - 2.0*(G%max_depth-half_depth) * ((k-(nz+1))/real(nz)) enddo + pi = 4.0*atan(1.0) do j=js,je Idamp_im(j) = damp_rate @@ -271,6 +300,10 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) y_2 = G%geoLatT(is,j) - G%south_lat - 0.5*G%len_lat eta_im(j,K) = eta0(k) + jet_height * tanh(y_2 / jet_width) ! jet_height * atan(y_2 / jet_width) + if (reentrant_y) then + y_2 = 2.*pi*y_2 + eta_im(j,K) = eta0(k) + jet_height * sin(y_2 / jet_width) + endif if (eta_im(j,K) > 0.0) eta_im(j,K) = 0.0 if (eta_im(j,K) < -G%max_depth) eta_im(j,K) = -G%max_depth enddo ; enddo diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index 4c633ebdc9..317ed4ac21 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -14,6 +14,7 @@ module dyed_channel_initialization use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : tracer_registry_type, tracer_name_lookup use MOM_tracer_registry, only : tracer_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -26,9 +27,9 @@ module dyed_channel_initialization !> Control structure for dyed-channel open boundaries. type, public :: dyed_channel_OBC_CS ; private - real :: zonal_flow = 8.57 !< Mean inflow - real :: tidal_amp = 0.0 !< Sloshing amplitude - real :: frequency = 0.0 !< Sloshing frequency + real :: zonal_flow = 8.57 !< Mean inflow [L T-1 ~> m s-1] + real :: tidal_amp = 0.0 !< Sloshing amplitude [L T-1 ~> m s-1] + real :: frequency = 0.0 !< Sloshing frequency [T-1 ~> s-1] end type dyed_channel_OBC_CS integer :: ntr = 0 !< Number of dye tracers @@ -37,9 +38,10 @@ module dyed_channel_initialization contains !> Add dyed channel to OBC registry. -function register_dyed_channel_OBC(param_file, CS, OBC_Reg) +function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(dyed_channel_OBC_CS), pointer :: CS !< Dyed channel control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. ! Local variables logical :: register_dyed_channel_OBC @@ -55,13 +57,13 @@ function register_dyed_channel_OBC(param_file, CS, OBC_Reg) call get_param(param_file, mdl, "CHANNEL_MEAN_FLOW", CS%zonal_flow, & "Mean zonal flow imposed at upstream open boundary.", & - units="m/s", default=8.57) + units="m/s", default=8.57, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "CHANNEL_TIDAL_AMP", CS%tidal_amp, & "Sloshing amplitude imposed at upstream open boundary.", & - units="m/s", default=0.0) + units="m/s", default=0.0, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "CHANNEL_FLOW_FREQUENCY", CS%frequency, & "Frequency of oscillating zonal flow.", & - units="s-1", default=0.0) + units="s-1", default=0.0, scale=US%T_to_s) ! Register the open boundaries. call register_OBC(casename, param_file, OBC_Reg) @@ -142,7 +144,9 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, Time) ! Local variables character(len=40) :: mdl = "dyed_channel_update_flow" ! This subroutine's name. character(len=80) :: name - real :: flow, time_sec, PI + real :: flow ! The OBC velocity [L T-1 ~> m s-1] + real :: PI ! 3.1415926535... + real :: time_sec ! The elapsed time since the start of the calendar [T ~> s] integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() @@ -150,7 +154,7 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, Time) if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & 'dyed_channel_update_flow() was called but OBC type was not initialized!') - time_sec = time_type_to_real(Time) + time_sec = G%US%s_to_T * time_type_to_real(Time) PI = 4.0*atan(1.0) do l=1, OBC%number_of_segments @@ -163,9 +167,9 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, Time) jsd = segment%HI%jsd ; jed = segment%HI%jed IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB if (CS%frequency == 0.0) then - flow = G%US%m_s_to_L_T*CS%zonal_flow + flow = CS%zonal_flow else - flow = G%US%m_s_to_L_T*CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) + flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) endif do k=1,GV%ke do j=jsd,jed ; do I=IsdB,IedB diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 7bf6aebf59..041d77d9f9 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -30,20 +30,21 @@ module shelfwave_initialization type, public :: shelfwave_OBC_CS ; private real :: Lx = 100.0 !< Long-shore length scale of bathymetry. real :: Ly = 50.0 !< Cross-shore length scale. - real :: f0 = 1.e-4 !< Coriolis parameter. + real :: f0 = 1.e-4 !< Coriolis parameter [T-1 ~> s-1] real :: jj = 1 !< Cross-shore wave mode. real :: kk !< Parameter. real :: ll !< Longshore wavenumber. real :: alpha !< 1/Ly. - real :: omega !< Frequency. + real :: omega !< Frequency of the shelf wave [T-1 ~> s-1] end type shelfwave_OBC_CS contains !> Add shelfwave to OBC registry. -function register_shelfwave_OBC(param_file, CS, OBC_Reg) +function register_shelfwave_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(shelfwave_OBC_CS), pointer :: CS !< shelfwave control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. logical :: register_shelfwave_OBC ! Local variables @@ -62,18 +63,20 @@ function register_shelfwave_OBC(param_file, CS, OBC_Reg) ! Register the tracer for horizontal advection & diffusion. call register_OBC(casename, param_file, OBC_Reg) - call get_param(param_file, mdl,"F_0",CS%f0, & - do_not_log=.true.) - call get_param(param_file, mdl,"LENLAT",len_lat, & + call get_param(param_file, mdl, "F_0", CS%f0, & + default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) + call get_param(param_file, mdl, "LENLAT", len_lat, & do_not_log=.true.) call get_param(param_file, mdl,"SHELFWAVE_X_WAVELENGTH",CS%Lx, & "Length scale of shelfwave in x-direction.",& units="Same as x,y", default=100.) - call get_param(param_file, mdl,"SHELFWAVE_Y_LENGTH_SCALE",CS%Ly, & +! units="km", default=100.0, scale=1.0e3*US%m_to_L) + call get_param(param_file, mdl, "SHELFWAVE_Y_LENGTH_SCALE", CS%Ly, & "Length scale of exponential dropoff of topography "//& "in the y-direction.", & units="Same as x,y", default=50.) - call get_param(param_file, mdl,"SHELFWAVE_Y_MODE",CS%jj, & +! units="km", default=50.0, scale=1.0e3*US%m_to_L) + call get_param(param_file, mdl, "SHELFWAVE_Y_MODE", CS%jj, & "Cross-shore wave mode.", & units="nondim", default=1.) CS%alpha = 1. / CS%Ly @@ -126,19 +129,23 @@ subroutine shelfwave_initialize_topography( D, G, param_file, max_depth, US ) end subroutine shelfwave_initialize_topography !> This subroutine sets the properties of flow at open boundary conditions. -subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, h, Time) - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies - !! whether, where, and what open boundary - !! conditions are used. - type(shelfwave_OBC_CS), pointer :: CS !< tidal bay control structure. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure +subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(shelfwave_OBC_CS), pointer :: CS !< tidal bay control structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness. type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the shelfwave example. - real :: my_amp, time_sec - real :: cos_wt, cos_ky, sin_wt, sin_ky, omega, alpha + real :: my_amp ! Amplitude of the open boundary current inflows [L T-1 ~> m s-1] + real :: time_sec ! The time in the run [T ~> s] + real :: cos_wt, cos_ky, sin_wt, sin_ky + real :: omega ! Frequency of the shelf wave [T-1 ~> s-1] + real :: alpha real :: x, y, jj, kk, ll character(len=40) :: mdl = "shelfwave_set_OBC_data" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, n @@ -151,10 +158,10 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, h, Time) if (.not.associated(OBC)) return - time_sec = time_type_to_real(Time) + time_sec = US%s_to_T*time_type_to_real(Time) omega = CS%omega alpha = CS%alpha - my_amp = 1.0 + my_amp = 1.0*G%US%m_s_to_L_T jj = CS%jj kk = CS%kk ll = CS%ll @@ -172,9 +179,9 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, h, Time) cos_wt = cos(ll*x - omega*time_sec) sin_ky = sin(kk * y) cos_ky = cos(kk * y) - segment%normal_vel_bt(I,j) = G%US%m_s_to_L_T*my_amp * exp(- alpha * y) * cos_wt * & + segment%normal_vel_bt(I,j) = my_amp * exp(- alpha * y) * cos_wt * & (alpha * sin_ky + kk * cos_ky) -! segment%tangential_vel_bt(I,j) = G%US%m_s_to_L_T*my_amp * ll * exp(- alpha * y) * sin_wt * sin_ky +! segment%tangential_vel_bt(I,j) = my_amp * ll * exp(- alpha * y) * sin_wt * sin_ky ! segment%vorticity_bt(I,j) = my_amp * exp(- alpha * y) * cos_wt * sin_ky& ! (ll*ll + kk*kk + alpha*alpha) enddo ; enddo diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index e6db433f60..b3c8f45843 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -12,6 +12,7 @@ module tidal_bay_initialization use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_segment_type, register_OBC use MOM_open_boundary, only : OBC_registry_type +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_time_manager, only : time_type, time_type_to_real @@ -24,18 +25,20 @@ module tidal_bay_initialization !> Control structure for tidal bay open boundaries. type, public :: tidal_bay_OBC_CS ; private - real :: tide_flow = 3.0e6 !< Maximum tidal flux. + real :: tide_flow = 3.0e6 !< Maximum tidal flux [L2 Z T-1 ~> m3 s-1] end type tidal_bay_OBC_CS contains !> Add tidal bay to OBC registry. -function register_tidal_bay_OBC(param_file, CS, OBC_Reg) +function register_tidal_bay_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(tidal_bay_OBC_CS), pointer :: CS !< tidal bay control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. logical :: register_tidal_bay_OBC character(len=32) :: casename = "tidal bay" !< This case's name. + character(len=40) :: mdl = "tidal_bay_initialization" ! This module's name. if (associated(CS)) then call MOM_error(WARNING, "register_tidal_bay_OBC called with an "// & @@ -44,6 +47,10 @@ function register_tidal_bay_OBC(param_file, CS, OBC_Reg) endif allocate(CS) + call get_param(param_file, mdl, "TIDAL_BAY_FLOW", CS%tide_flow, & + "Maximum total tidal volume flux.", & + units="m3 s-1", default=3.0d6, scale=US%m_s_to_L_T*US%m_to_L*US%m_to_Z) + ! Register the open boundaries. call register_OBC(casename, param_file, OBC_Reg) register_tidal_bay_OBC = .true. @@ -67,14 +74,17 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, h, Time) type(tidal_bay_OBC_CS), pointer :: CS !< tidal bay control structure. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the tidal_bay example. - real :: time_sec, cff - real :: my_flux, total_area + real :: time_sec + real :: cff_eta ! The total column thickness anomalies associated with the inflow [H ~> m or kg m-2] + real :: my_flux ! The vlume flux through the face [L2 Z T-1 ~> m3 s-1] + real :: total_area ! The total face area of the OBCs [L Z ~> m2] real :: PI - real, allocatable :: my_area(:,:) + real :: flux_scale ! A scaling factor for the areas [m2 H-1 L-1 ~> nondim or m3 kg-1] + real, allocatable :: my_area(:,:) ! The total OBC inflow area [m2] character(len=40) :: mdl = "tidal_bay_set_OBC_data" ! This subroutine's name. integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz, n integer :: IsdB, IedB, JsdB, JedB @@ -90,8 +100,10 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, h, Time) allocate(my_area(1:1,js:je)) + flux_scale = GV%H_to_m*G%US%L_to_m + time_sec = time_type_to_real(Time) - cff = 0.1*sin(2.0*PI*time_sec/(12.0*3600.0)) + cff_eta = 0.1*GV%m_to_H * sin(2.0*PI*time_sec/(12.0*3600.0)) my_area=0.0 my_flux=0.0 segment => OBC%segment(1) @@ -99,7 +111,8 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, h, Time) do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB if (OBC%segnum_u(I,j) /= OBC_NONE) then do k=1,nz - my_area(1,j) = my_area(1,j) + h(I,j,k)*G%US%L_to_m*G%dyCu(I,j) + ! This area has to be in MKS units to work with reproducing_sum. + my_area(1,j) = my_area(1,j) + h(I,j,k)*flux_scale*G%dyCu(I,j) enddo endif enddo ; enddo @@ -111,8 +124,8 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, h, Time) if (.not. segment%on_pe) cycle - segment%normal_vel_bt(:,:) = G%US%m_s_to_L_T*my_flux/total_area - segment%eta(:,:) = cff + segment%normal_vel_bt(:,:) = my_flux / (G%US%m_to_Z*G%US%m_to_L*total_area) + segment%eta(:,:) = cff_eta enddo ! end segment loop