diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5d84c0c176..5e1da1c1f9 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,113 +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 - # Show hashes for final setup - - git show --oneline - - git submodule status - - (cd MOM6-examples && git submodule status --recursive src) - # 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: @@ -115,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: @@ -157,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 45d05cd23f..06b29dc690 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -521,9 +521,10 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 $(VENV_PATH) @echo -e "$(DONE): $$*.$(1); no runtime errors." if [ $(3) ]; then \ mkdir -p results/$$* ; \ - bash <(curl -s https://codecov.io/bash) -n $$@ \ - > work/$$*/codecov.$(1).out \ - 2> work/$$*/codecov.$(1).err \ + cd build/symmetric \ + && bash <(curl -s https://codecov.io/bash) -Z -n $$@ \ + > codecov.$$*.$(1).out \ + 2> codecov.$$*.$(1).err \ && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}"; \ fi endef 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 162b7f5f8d..6479549eb7 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -111,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 @@ -291,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 @@ -336,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 @@ -360,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 @@ -370,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 @@ -382,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 @@ -410,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 @@ -1112,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 @@ -1252,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 @@ -1375,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") @@ -1422,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") diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 2deeb40742..50ea6c943d 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -55,7 +55,7 @@ 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 @@ -195,8 +195,8 @@ module ocean_model_mod type(unit_scale_type), pointer :: & US => NULL() !< A pointer to a structure containing dimensional !! unit scaling factors. - type(MOM_control_struct), pointer :: & - MOM_CSp => NULL() !< A pointer to the MOM control structure + type(MOM_control_struct) :: MOM_CSp + !< MOM control structure type(ice_shelf_CS), pointer :: & Ice_shelf_CSp => NULL() !< A pointer to the control structure for the !! ice shelf model that couples with MOM6. This @@ -205,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 :: & @@ -382,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) 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 bd6c7fe66e..3bd0e1e28d 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -61,7 +61,7 @@ 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 @@ -195,8 +195,8 @@ module MOM_ocean_model_mct !! about the vertical grid. type(unit_scale_type), pointer :: US => NULL() !< A pointer to a structure containing !! dimensional unit scaling factors. - type(MOM_control_struct), pointer :: & - MOM_CSp => NULL() !< A pointer to the MOM control structure + type(MOM_control_struct) :: MOM_CSp + !< MOM control structure type(ice_shelf_CS), pointer :: & Ice_shelf_CSp => NULL() !< A pointer to the control structure for the !! ice shelf model that couples with MOM6. This @@ -205,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 :: & @@ -383,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, & diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 2d79674606..394cf05285 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 @@ -421,6 +421,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 @@ -695,8 +696,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), & @@ -704,10 +706,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) @@ -752,7 +756,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 b8bcf8ff87..1eae1da4d1 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -57,8 +57,8 @@ 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 @@ -80,7 +80,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. @@ -197,8 +197,8 @@ module MOM_ocean_model_nuopc !! about the vertical grid. type(unit_scale_type), pointer :: US => NULL() !< A pointer to a structure containing !! dimensional unit scaling factors. - type(MOM_control_struct), pointer :: & - MOM_CSp => NULL() !< A pointer to the MOM control structure + type(MOM_control_struct) :: MOM_CSp + !< MOM control structure type(ice_shelf_CS), pointer :: & Ice_shelf_CSp => NULL() !< A pointer to the control structure for the !! ice shelf model that couples with MOM6. This @@ -206,8 +206,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 :: & @@ -388,14 +388,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, & @@ -1005,6 +1000,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. diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 8edad7fa05..7dfce01f68 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 @@ -180,8 +180,7 @@ program MOM_main ! and diffusion equation are read in from files stored from ! a previous integration of the prognostic model - type(MOM_control_struct), pointer :: MOM_CSp => NULL() - !> A pointer to the tracer flow control structure. + type(MOM_control_struct) :: MOM_CSp !> MOM control structure type(tracer_flow_control_CS), pointer :: & tracer_flow_CSp => NULL() !< A pointer to the tracer flow control structure type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() @@ -331,11 +330,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/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 1f2e949f0c..6f08065f57 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -498,10 +498,12 @@ subroutine get_file_fields(IO_handle, fields) do i=1,nvar fields(i)%name = trim(var_names(i)) longname = "" - call get_variable_attribute(IO_handle%fileobj, var_names(i), 'long_name', longname) + 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 = "" - call get_variable_attribute(IO_handle%fileobj, var_names(i), 'units', 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") 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 4659b685e5..63c78db77f 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 @@ -40,7 +41,7 @@ module MOM use MOM_io, only : slasher, file_exists, MOM_read_data 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 : query_initialized, save_restart, restart_registry_lock 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(+) @@ -63,6 +64,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 @@ -83,9 +85,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 @@ -95,15 +98,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 @@ -428,7 +434,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS type(surface), target, intent(inout) :: sfc_state !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type real, intent(in) :: time_int_in !< time interval covered by this run segment [s]. - type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM + type(MOM_control_struct), intent(inout), target :: CS !< control structure from initialize_MOM type(Wave_parameters_CS), & optional, pointer :: Waves !< An optional pointer to a wave property CS logical, optional, intent(in) :: do_dynamics !< Present and false, do not do updates due @@ -975,7 +981,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & real, intent(in) :: bbl_time_int !< time interval over which updates to the !! bottom boundary layer properties will apply [T ~> s], !! or zero not to update the properties. - type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM + type(MOM_control_struct), intent(inout), target :: CS !< control structure from initialize_MOM type(time_type), intent(in) :: Time_local !< End time of a segment, as a time type type(wave_parameters_CS), & optional, pointer :: Waves !< Container for wave related parameters; the @@ -1426,7 +1432,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS type(surface), intent(inout) :: sfc_state !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type real, intent(in) :: time_interval !< time interval - type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM + type(MOM_control_struct), intent(inout) :: CS !< control structure from initialize_MOM ! Local pointers type(ocean_grid_type), pointer :: G => NULL() ! Pointer to a structure containing @@ -1624,7 +1630,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar type(param_file_type), intent(out) :: param_file !< structure indicating parameter file to parse type(directories), intent(out) :: dirs !< structure with directory paths - type(MOM_control_struct), pointer :: CS !< pointer set in this routine to MOM control structure + type(MOM_control_struct), intent(inout), target :: CS !< pointer set in this routine to MOM control structure type(MOM_restart_CS), pointer :: restart_CSp !< pointer set in this routine to the !! restart control structure that will !! be used for MOM. @@ -1724,13 +1730,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & type(ocean_internal_state) :: MOM_internal_state character(len=200) :: area_varname, ice_shelf_file, inputdir, filename - if (associated(CS)) then - call MOM_error(WARNING, "initialize_MOM called with an associated "// & - "control structure.") - return - endif - allocate(CS) - CS%Time => Time id_clock_init = cpu_clock_id('Ocean Initialization', grain=CLOCK_SUBCOMPONENT) @@ -2146,8 +2145,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (associated(OBC_in)) then ! TODO: General OBC index rotations is not yet supported. if (modulo(turns, 4) /= 1) & - call MOM_error(FATAL, "OBC index rotation of 180 and 270 degrees is " & - // "not yet unsupported.") + call MOM_error(FATAL, "OBC index rotation of 180 and 270 degrees is not yet supported.") allocate(CS%OBC) call rotate_OBC_config(OBC_in, dG_in, CS%OBC, dG, turns) endif @@ -2168,8 +2166,6 @@ 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) - call tracer_registry_init(param_file, CS%tracer_Reg) ! Allocate and initialize space for the primary time-varying MOM variables. @@ -2223,21 +2219,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & flux_scale=conv2salt, convergence_units='kg m-2 s-1', & convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendprefix="osalt", diag_form=2) endif - ! NOTE: register_temp_salt_segments includes allocation of tracer fields - ! along segments. Bit reproducibility requires that MOM_initialize_state - ! be called on the input index map, so we must setup both OBC and OBC_in. - ! - ! XXX: This call on OBC_in allocates the tracer fields on the unrotated - ! grid, but also incorrectly stores a pointer to a tracer_type for the - ! rotated registry (e.g. segment%tr_reg%Tr(n)%Tr) from CS%tracer_reg. - ! - ! While incorrect and potentially dangerous, it does not seem that this - ! pointer is used during initialization, so we leave it for now. - if (CS%rotate_index .and. associated(OBC_in)) & - call register_temp_salt_segments(GV, OBC_in, CS%tracer_Reg, param_file) - if (associated(CS%OBC)) & - call register_temp_salt_segments(GV, CS%OBC, CS%tracer_Reg, param_file) endif + if (use_frazil) then allocate(CS%tv%frazil(isd:ied,jsd:jed)) ; CS%tv%frazil(:,:) = 0.0 endif @@ -2330,11 +2313,38 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call mixedlayer_restrat_register_restarts(dG%HI, param_file, & CS%mixedlayer_restrat_CSp, restart_CSp) - if (associated(CS%OBC)) & + if (CS%rotate_index .and. associated(OBC_in) .and. use_temperature) then + ! NOTE: register_temp_salt_segments includes allocation of tracer fields + ! along segments. Bit reproducibility requires that MOM_initialize_state + ! be called on the input index map, so we must setup both OBC and OBC_in. + ! + ! XXX: This call on OBC_in allocates the tracer fields on the unrotated + ! grid, but also incorrectly stores a pointer to a tracer_type for the + ! rotated registry (e.g. segment%tr_reg%Tr(n)%Tr) from CS%tracer_reg. + ! + ! While incorrect and potentially dangerous, it does not seem that this + ! pointer is used during initialization, so we leave it for now. + call register_temp_salt_segments(GV, OBC_in, CS%tracer_Reg, param_file) + endif + + if (associated(CS%OBC)) then + ! Set up remaining information about open boundary conditions that is needed for OBCs. + call call_OBC_register(param_file, CS%update_OBC_CSp, US, CS%OBC, CS%tracer_Reg) + !### Package specific changes to OBCs need to go here? + + ! This is the equivalent to 2 calls to register_segment_tracer (per segment), which + ! could occur with the call to update_OBC_data or after the main initialization. + if (use_temperature) & + call register_temp_salt_segments(GV, CS%OBC, CS%tracer_Reg, param_file) + + ! This needs the number of tracers and to have called any code that sets whether + ! reservoirs are used. call open_boundary_register_restarts(dg%HI, GV, CS%OBC, CS%tracer_Reg, & param_file, restart_CSp, use_temperature) + endif call callTree_waypoint("restart registration complete (initialize_MOM)") + call restart_registry_lock(restart_CSp) ! Shift from using the temporary dynamic grid type to using the final ! (potentially static) ocean-specific grid type. @@ -2432,7 +2442,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & turns, CS%u, CS%v, CS%h, CS%T, CS%S) if (associated(sponge_in_CSp)) then - ! TODO: Implementation and testing of non-ALE spong rotation + ! TODO: Implementation and testing of non-ALE sponge rotation call MOM_error(FATAL, "Index rotation of non-ALE sponge is not yet implemented.") endif @@ -2472,19 +2482,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif if (use_ice_shelf .and. CS%debug) & - call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, & - haloshift=0) + call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, haloshift=0) call cpu_clock_end(id_clock_MOM_init) call callTree_waypoint("returned from MOM_initialize_state() (initialize_MOM)") -! ! Need this after MOM_initialize_state for DOME OBC stuff. -! if (associated(CS%OBC)) & -! call open_boundary_register_restarts(G%HI, GV, CS%OBC, CS%tracer_Reg, & -! param_file, restart_CSp, use_temperature) - -! call callTree_waypoint("restart registration complete (initialize_MOM)") - ! From this point, there may be pointers being set, so the final grid type ! that will persist throughout the run has to be used. @@ -2812,7 +2814,7 @@ end subroutine initialize_MOM subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) type(time_type), intent(in) :: Time !< model time, used in this routine type(directories), intent(in) :: dirs !< structure with directory paths - type(MOM_control_struct), pointer :: CS !< pointer to MOM control structure + type(MOM_control_struct), intent(inout) :: CS !< MOM control structure type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control !! structure that will be used for MOM. ! Local variables @@ -2839,6 +2841,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) if (CS%write_IC) then allocate(restart_CSp_tmp) restart_CSp_tmp = restart_CSp + call restart_registry_lock(restart_CSp_tmp, unlocked=.true.) allocate(z_interface(SZI_(G),SZJ_(G),SZK_(GV)+1)) 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, & @@ -3038,7 +3041,7 @@ end subroutine adjust_ssh_for_p_atm !! setting the appropriate fields in sfc_state. Unused fields !! are set to NULL or are unallocated. subroutine extract_surface_state(CS, sfc_state_in) - type(MOM_control_struct), pointer :: CS !< Master MOM control structure + type(MOM_control_struct), intent(inout), target :: CS !< Master MOM control structure type(surface), target, intent(inout) :: sfc_state_in !< transparent ocean surface state !! structure shared with the calling routine !! data in this structure is intent out. @@ -3465,7 +3468,7 @@ end subroutine rotate_initial_state !> Return true if all phases of step_MOM are at the same point in time. function MOM_state_is_synchronized(CS, adv_dyn) result(in_synch) - type(MOM_control_struct), pointer :: CS !< MOM control structure + type(MOM_control_struct), intent(inout) :: CS !< MOM control structure logical, optional, intent(in) :: adv_dyn !< If present and true, only check !! whether the advection is up-to-date with !! the dynamics. @@ -3486,7 +3489,7 @@ end function MOM_state_is_synchronized !> This subroutine offers access to values or pointers to other types from within !! the MOM_control_struct, allowing the MOM_control_struct to be opaque. subroutine get_MOM_state_elements(CS, G, GV, US, C_p, C_p_scaled, use_temp) - type(MOM_control_struct), pointer :: CS !< MOM control structure + type(MOM_control_struct), intent(inout), target :: CS !< MOM control structure type(ocean_grid_type), optional, pointer :: G !< structure containing metrics and grid info type(verticalGrid_type), optional, pointer :: GV !< structure containing vertical grid info type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type @@ -3505,7 +3508,7 @@ end subroutine get_MOM_state_elements !> Find the global integrals of various quantities. subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) - type(MOM_control_struct), pointer :: CS !< MOM control structure + type(MOM_control_struct), intent(inout) :: CS !< MOM control structure real, optional, intent(out) :: heat !< The globally integrated integrated ocean heat [J]. real, optional, intent(out) :: salt !< The globally integrated integrated ocean salt [kg]. real, optional, intent(out) :: mass !< The globally integrated integrated ocean mass [kg]. @@ -3522,30 +3525,30 @@ end subroutine get_ocean_stocks !> End of ocean model, including memory deallocation subroutine MOM_end(CS) - type(MOM_control_struct), pointer :: CS !< MOM control structure + type(MOM_control_struct), intent(inout) :: 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 @@ -3553,15 +3556,64 @@ 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) + + ! The MPP domains may be needed by an external coupler, so use `cursory`. + ! TODO: This may create a domain memory leak, and needs investigation. + call deallocate_MOM_domain(CS%G_in%domain, cursory=.true.) + + call unit_scaling_end(CS%US) end subroutine MOM_end !> \namespace mom diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 231b6ed058..e4d97ab53a 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -1406,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 5b6fa03bb8..4d19459bc7 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 @@ -5008,19 +5008,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..dc89f3f92c 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -17,6 +17,7 @@ module MOM_boundary_update use MOM_tracer_registry, only : tracer_registry_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type +use DOME_initialization, only : register_DOME_OBC use tidal_bay_initialization, only : tidal_bay_set_OBC_data, register_tidal_bay_OBC use tidal_bay_initialization, only : tidal_bay_OBC_end, tidal_bay_OBC_CS use Kelvin_initialization, only : Kelvin_set_OBC_data, register_Kelvin_OBC @@ -58,12 +59,15 @@ 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, tr_Reg) 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 + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. ! Local variables + character(len=200) :: config character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -90,21 +94,40 @@ subroutine call_OBC_register(param_file, CS, OBC) call get_param(param_file, mdl, "USE_DYED_CHANNEL_OBC", CS%use_dyed_channel, & "If true, use the dyed channel open boundary.", & default=.false.) + call get_param(param_file, mdl, "OBC_USER_CONFIG", config, & + "A string that sets how the user code is invoked to set open boundary data: \n"//& + " DOME - specified inflow on northern boundary\n"//& + " dyed_channel - supercritical with dye on the inflow boundary\n"//& + " dyed_obcs - circle_obcs with dyes on the open boundaries\n"//& + " Kelvin - barotropic Kelvin wave forcing on the western boundary\n"//& + " shelfwave - Flather with shelf wave forcing on western boundary\n"//& + " supercritical - now only needed here for the allocations\n"//& + " tidal_bay - Flather with tidal forcing on eastern boundary\n"//& + " USER - user specified", default="none", do_not_log=.true.) 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 (trim(config) == "DOME") then + call register_DOME_OBC(param_file, US, OBC, tr_Reg) +! elseif (trim(config) == "tidal_bay") then +! elseif (trim(config) == "Kelvin") then +! elseif (trim(config) == "shelfwave") then +! elseif (trim(config) == "dyed_channel") then + endif + 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 +151,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) & @@ -149,7 +172,7 @@ end subroutine OBC_register_end !> \namespace mom_boundary_update !! This module updates the open boundary arrays when time-varying. -!! It caused a circular dependency with the tidal_bay setup when +!! It caused a circular dependency with the tidal_bay and other setups when in !! MOM_open_boundary. !! !! A small fragment of the grid is shown below: 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 ebe53fc908..96a0a5f92f 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 @@ -1715,6 +1721,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_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_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 0cb81e9978..61e20d14a6 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 @@ -341,8 +342,6 @@ module MOM_open_boundary integer :: id_clock_pass !< A CPU time clock character(len=40) :: mdl = "MOM_open_boundary" !< This module's name. -! This include declares and sets the variable "version". -#include "version_variable.h" contains @@ -358,6 +357,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handle type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + ! Local variables integer :: l ! For looping over segments logical :: debug_OBC, debug, mask_outside, reentrant_x, reentrant_y @@ -369,6 +369,9 @@ subroutine open_boundary_config(G, US, param_file, OBC) logical :: answers_2018, default_2018_answers logical :: check_reconstruction, check_remapping, force_bounds_in_subcell character(len=32) :: remappingScheme +! This include declares and sets the variable "version". +# include "version_variable.h" + allocate(OBC) call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & @@ -4432,8 +4435,8 @@ subroutine register_OBC(name, param_file, Reg) Reg%OB(nobc)%name = name if (Reg%locked) call MOM_error(FATAL, & - "MOM register_tracer was called for variable "//trim(Reg%OB(nobc)%name)//& - " with a locked tracer registry.") + "MOM register_OBC was called for OBC "//trim(Reg%OB(nobc)%name)//& + " with a locked OBC registry.") end subroutine register_OBC @@ -4444,7 +4447,7 @@ subroutine OBC_registry_init(param_file, Reg) integer, save :: init_calls = 0 -#include "version_variable.h" +# include "version_variable.h" character(len=40) :: mdl = "MOM_open_boundary" ! This module's name. character(len=256) :: mesg ! Message for error messages. @@ -4452,7 +4455,7 @@ subroutine OBC_registry_init(param_file, Reg) else ; return ; endif ! Read all relevant parameters and write them to the model log. -! call log_version(param_file, mdl,s version, "") +! call log_version(param_file, mdl, version, "") init_calls = init_calls + 1 if (init_calls > 1) then @@ -4464,9 +4467,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. @@ -4501,7 +4505,7 @@ subroutine segment_tracer_registry_init(param_file, segment) integer, save :: init_calls = 0 ! This include declares and sets the variable "version". -#include "version_variable.h" +# include "version_variable.h" character(len=40) :: mdl = "segment_tracer_registry_init" ! This routine's name. character(len=256) :: mesg ! Message for error messages. @@ -4525,6 +4529,8 @@ subroutine segment_tracer_registry_init(param_file, segment) end subroutine segment_tracer_registry_init +!> Register a tracer array that is active on an OBC segment, potentially also specifing how the +!! tracer inflow values are specified. subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & OBC_scalar, OBC_array) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -4535,7 +4541,7 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & !! but it also means that any updates to this !! structure in the calling module will be !! available subsequently to the tracer registry. - type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values type(OBC_segment_type), intent(inout) :: segment !< current segment data structure real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer !! inflow concentration. @@ -4553,8 +4559,8 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & if (segment%tr_Reg%ntseg>=MAX_FIELDS_) then write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & - &all the tracers being registered via register_tracer.")') segment%tr_Reg%ntseg+1 - call MOM_error(FATAL,"MOM register_tracer: "//mesg) + &all the tracers being registered via register_segment_tracer.")') segment%tr_Reg%ntseg+1 + call MOM_error(FATAL,"MOM register_segment_tracer: "//mesg) endif segment%tr_Reg%ntseg = segment%tr_Reg%ntseg + 1 ntseg = segment%tr_Reg%ntseg @@ -4568,7 +4574,7 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & segment%tr_Reg%Tr(ntseg)%name = tr_ptr%name if (segment%tr_Reg%locked) call MOM_error(FATAL, & - "MOM register_tracer was called for variable "//trim(segment%tr_Reg%Tr(ntseg)%name)//& + "MOM register_segment_tracer was called for variable "//trim(segment%tr_Reg%Tr(ntseg)%name)//& " with a locked tracer registry.") if (present(OBC_scalar)) segment%tr_Reg%Tr(ntseg)%OBC_inflow_conc = OBC_scalar ! initialize tracer value later diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index f7f35ed2d1..ab85db8baf 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -169,6 +169,10 @@ module MOM_variables PFv => NULL(), & !< Meridional acceleration due to pressure forces [L T-2 ~> m s-2] du_dt_visc => NULL(), &!< Zonal acceleration due to vertical viscosity [L T-2 ~> m s-2] dv_dt_visc => NULL(), &!< Meridional acceleration due to vertical viscosity [L T-2 ~> m s-2] + du_dt_str => NULL(), & !< Zonal acceleration due to the surface stress (included + !! in du_dt_visc) [L T-2 ~> m s-2] + dv_dt_str => NULL(), & !< Meridional acceleration due to the surface stress (included + !! in dv_dt_visc) [L T-2 ~> m s-2] du_dt_dia => NULL(), & !< Zonal acceleration due to diapycnal mixing [L T-2 ~> m s-2] dv_dt_dia => NULL(), & !< Meridional acceleration due to diapycnal mixing [L T-2 ~> m s-2] u_accel_bt => NULL(), &!< Pointer to the zonal barotropic-solver acceleration [L T-2 ~> m s-2] diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index f874d08a12..cc16a25fc3 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -107,6 +107,7 @@ module MOM_diagnostics !! of this spurious Coriolis source. KE_adv => NULL(), & !< KE source from along-layer advection [H L2 T-3 ~> m3 s-3] KE_visc => NULL(), & !< KE source from vertical viscosity [H L2 T-3 ~> m3 s-3] + KE_stress => NULL(), & !< KE source from surface stress (included in KE_visc) [H L2 T-3 ~> m3 s-3] KE_horvisc => NULL(), & !< KE source from horizontal viscosity [H L2 T-3 ~> m3 s-3] KE_dia => NULL() !< KE source from diapycnal diffusion [H L2 T-3 ~> m3 s-3] @@ -121,8 +122,8 @@ module MOM_diagnostics integer :: id_col_ht = -1, id_dh_dt = -1 integer :: id_KE = -1, id_dKEdt = -1 integer :: id_PE_to_KE = -1, id_KE_BT = -1 - integer :: id_KE_Coradv = -1 - integer :: id_KE_adv = -1, id_KE_visc = -1 + integer :: id_KE_Coradv = -1, id_KE_adv = -1 + integer :: id_KE_visc = -1, id_KE_stress = -1 integer :: id_KE_horvisc = -1, id_KE_dia = -1 integer :: id_uh_Rlay = -1, id_vh_Rlay = -1 integer :: id_uhGM_Rlay = -1, id_vhGM_Rlay = -1 @@ -197,7 +198,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 @@ -227,11 +228,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] @@ -390,7 +386,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 @@ -400,7 +396,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 @@ -1065,7 +1061,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS KE_h(i,j) = CS%KE(i,j,k) * CS%dh_dt(i,j,k) enddo ; enddo if (.not.G%symmetric) & - call do_group_pass(CS%pass_KE_uv, G%domain) + call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie CS%dKE_dt(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) @@ -1083,7 +1079,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%PFv(i,J,k) enddo ; enddo if (.not.G%symmetric) & - call do_group_pass(CS%pass_KE_uv, G%domain) + call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie CS%PE_to_KE(i,j,k) = 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) @@ -1101,7 +1097,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%v_accel_bt(i,J,k) enddo ; enddo if (.not.G%symmetric) & - call do_group_pass(CS%pass_KE_uv, G%domain) + call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie CS%KE_BT(i,j,k) = 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) @@ -1123,7 +1119,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS * (uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) enddo ; enddo if (.not.G%symmetric) & - call do_group_pass(CS%pass_KE_uv, G%domain) + call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie CS%KE_CorAdv(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) @@ -1151,7 +1147,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS * (uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) enddo ; enddo if (.not.G%symmetric) & - call do_group_pass(CS%pass_KE_uv, G%domain) + call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie CS%KE_adv(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) @@ -1169,7 +1165,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_visc(i,J,k) enddo ; enddo if (.not.G%symmetric) & - call do_group_pass(CS%pass_KE_uv, G%domain) + call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie CS%KE_visc(i,j,k) = 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) @@ -1178,6 +1174,24 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (CS%id_KE_visc > 0) call post_data(CS%id_KE_visc, CS%KE_visc, CS%diag) endif + if (associated(CS%KE_stress)) then + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_str(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_str(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + CS%KE_stress(i,j,k) = 0.5 * G%IareaT(i,j) * & + ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + if (CS%id_KE_stress > 0) call post_data(CS%id_KE_stress, CS%KE_stress, CS%diag) + endif + if (associated(CS%KE_horvisc)) then do k=1,nz do j=js,je ; do I=Isq,Ieq @@ -1187,7 +1201,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%diffv(i,J,k) enddo ; enddo if (.not.G%symmetric) & - call do_group_pass(CS%pass_KE_uv, G%domain) + call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie CS%KE_horvisc(i,j,k) = 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) @@ -1208,7 +1222,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS 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) + call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie CS%KE_dia(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) @@ -1899,6 +1913,11 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_visc>0) call safe_alloc_ptr(CS%KE_visc,isd,ied,jsd,jed,nz) + CS%id_KE_stress = register_diag_field('ocean_model', 'KE_stress', diag%axesTL, Time, & + 'Kinetic Energy Source from Surface Stresses or Body Wind Stress', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + if (CS%id_KE_stress>0) call safe_alloc_ptr(CS%KE_stress,isd,ied,jsd,jed,nz) + CS%id_KE_horvisc = register_diag_field('ocean_model', 'KE_horvisc', diag%axesTL, Time, & 'Kinetic Energy Source from Horizontal Viscosity', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) @@ -1935,7 +1954,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) @@ -2299,7 +2318,7 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) if (associated(CS%dKE_dt) .or. associated(CS%PE_to_KE) .or. & associated(CS%KE_BT) .or. associated(CS%KE_CorAdv) .or. & - associated(CS%KE_adv) .or. associated(CS%KE_visc) .or. & + associated(CS%KE_adv) .or. associated(CS%KE_visc) .or. associated(CS%KE_stress) .or. & associated(CS%KE_horvisc) .or. associated(CS%KE_dia)) & call safe_alloc_ptr(CS%KE,isd,ied,jsd,jed,nz) @@ -2327,6 +2346,11 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) endif + if (associated(CS%KE_stress)) then + call safe_alloc_ptr(ADp%du_dt_str,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%dv_dt_str,isd,ied,JsdB,JedB,nz) + endif + if (associated(CS%KE_dia)) then call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) @@ -2339,11 +2363,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) @@ -2355,6 +2381,7 @@ subroutine MOM_diagnostics_end(CS, ADp) if (associated(CS%KE_Coradv)) deallocate(CS%KE_Coradv) if (associated(CS%KE_adv)) deallocate(CS%KE_adv) if (associated(CS%KE_visc)) deallocate(CS%KE_visc) + if (associated(CS%KE_stress)) deallocate(CS%KE_stress) if (associated(CS%KE_horvisc)) deallocate(CS%KE_horvisc) if (associated(CS%KE_dia)) deallocate(CS%KE_dia) if (associated(CS%dv_dt)) deallocate(CS%dv_dt) @@ -2370,6 +2397,8 @@ subroutine MOM_diagnostics_end(CS, ADp) if (associated(ADp%gradKEv)) deallocate(ADp%gradKEv) if (associated(ADp%du_dt_visc)) deallocate(ADp%du_dt_visc) if (associated(ADp%dv_dt_visc)) deallocate(ADp%dv_dt_visc) + if (associated(ADp%du_dt_str)) deallocate(ADp%du_dt_str) + if (associated(ADp%dv_dt_str)) deallocate(ADp%dv_dt_str) if (associated(ADp%du_dt_dia)) deallocate(ADp%du_dt_dia) if (associated(ADp%dv_dt_dia)) deallocate(ADp%dv_dt_dia) if (associated(ADp%du_other)) deallocate(ADp%du_other) @@ -2378,10 +2407,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 76dcd140a7..72523edfd3 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -33,7 +33,8 @@ module MOM_sum_output #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 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_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index afbc833483..4994646086 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3383,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 @@ -3398,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 @@ -3413,21 +3433,79 @@ 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 + + if (diag_cs%num_diag_coords > 0) then + 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) + endif + + 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 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_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_io.F90 b/src/framework/MOM_io.F90 index 3ad2c92f41..f8cfb09382 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -714,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) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 129f52ad4c..b2641aa622 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -22,10 +22,9 @@ module MOM_restart implicit none ; private public restart_init, restart_end, restore_state, register_restart_field -public save_restart, query_initialized, restart_init_end, vardesc +public save_restart, query_initialized, restart_registry_lock, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run -public register_restart_field_as_obsolete -public register_restart_pair +public register_restart_field_as_obsolete, register_restart_pair !> A type for making arrays of pointers to 4-d arrays type p4d @@ -87,6 +86,8 @@ module MOM_restart !! in which case the checksums will not match and cause crash. character(len=240) :: restartfile !< The name or name root for MOM restart files. integer :: turns !< Number of quarter turns from input to model domain + logical :: locked = .false. !< If true this registry has been locked and no further restart + !! fields can be added without explicitly unlocking the registry. !> An array of descriptions of the registered fields type(field_restart), pointer :: restart_field(:) => NULL() @@ -155,6 +156,8 @@ subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") + call lock_check(CS, var_desc) + CS%novars = CS%novars+1 if (CS%novars > CS%max_fields) return ! This is an error that will be reported ! once the total number of fields is known. @@ -186,6 +189,8 @@ subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") + call lock_check(CS, var_desc) + CS%novars = CS%novars+1 if (CS%novars > CS%max_fields) return ! This is an error that will be reported ! once the total number of fields is known. @@ -217,6 +222,8 @@ subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") + call lock_check(CS, var_desc) + CS%novars = CS%novars+1 if (CS%novars > CS%max_fields) return ! This is an error that will be reported ! once the total number of fields is known. @@ -247,6 +254,8 @@ subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") + call lock_check(CS, var_desc) + CS%novars = CS%novars+1 if (CS%novars > CS%max_fields) return ! This is an error that will be reported ! once the total number of fields is known. @@ -277,6 +286,8 @@ subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") + call lock_check(CS, var_desc) + CS%novars = CS%novars+1 if (CS%novars > CS%max_fields) return ! This is an error that will be reported ! once the total number of fields is known. @@ -307,6 +318,8 @@ subroutine register_restart_pair_ptr2d(a_ptr, b_ptr, a_desc, b_desc, & logical, intent(in) :: mandatory !< If true, abort if field is missing type(MOM_restart_CS), pointer :: CS !< MOM restart control structure + call lock_check(CS, a_desc) + if (modulo(CS%turns, 2) /= 0) then call register_restart_field(b_ptr, a_desc, mandatory, CS) call register_restart_field(a_ptr, b_desc, mandatory, CS) @@ -327,6 +340,8 @@ subroutine register_restart_pair_ptr3d(a_ptr, b_ptr, a_desc, b_desc, & logical, intent(in) :: mandatory !< If true, abort if field is missing type(MOM_restart_CS), pointer :: CS !< MOM restart control structure + call lock_check(CS, a_desc) + if (modulo(CS%turns, 2) /= 0) then call register_restart_field(b_ptr, a_desc, mandatory, CS) call register_restart_field(a_ptr, b_desc, mandatory, CS) @@ -347,6 +362,8 @@ subroutine register_restart_pair_ptr4d(a_ptr, b_ptr, a_desc, b_desc, & logical, intent(in) :: mandatory !< If true, abort if field is missing type(MOM_restart_CS), pointer :: CS !< MOM restart control structure + call lock_check(CS, a_desc) + if (modulo(CS%turns, 2) /= 0) then call register_restart_field(b_ptr, a_desc, mandatory, CS) call register_restart_field(a_ptr, b_desc, mandatory, CS) @@ -379,6 +396,9 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_4d: Module must be initialized before "//& "it is used to register "//trim(name)) + + call lock_check(CS, name=name) + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid) @@ -406,6 +426,9 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_3d: Module must be initialized before "//& "it is used to register "//trim(name)) + + call lock_check(CS, name=name) + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid) @@ -435,6 +458,9 @@ subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units "register_restart_field_2d: Module must be initialized before "//& "it is used to register "//trim(name)) zgrid = '1' ; if (present(z_grid)) zgrid = z_grid + + call lock_check(CS, name=name) + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=zgrid, t_grid=t_grid) @@ -463,6 +489,9 @@ subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units "register_restart_field_3d: Module must be initialized before "//& "it is used to register "//trim(name)) hgrid = '1' ; if (present(hor_grid)) hgrid = hor_grid + + call lock_check(CS, name=name) + vd = var_desc(name, units=units, longname=longname, hor_grid=hgrid, & z_grid=z_grid, t_grid=t_grid) @@ -483,9 +512,13 @@ subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent type(vardesc) :: vd + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_0d: Module must be initialized before "//& "it is used to register "//trim(name)) + + call lock_check(CS, name=name) + vd = var_desc(name, units=units, longname=longname, hor_grid='1', & z_grid='1', t_grid=t_grid) @@ -502,6 +535,7 @@ function query_initialized_name(name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -533,6 +567,7 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -557,6 +592,7 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -582,6 +618,7 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -607,6 +644,7 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -632,6 +670,7 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -658,6 +697,7 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -691,6 +731,7 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -724,6 +765,7 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -757,6 +799,7 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -790,6 +833,7 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -847,13 +891,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 + 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=64) :: var_name ! A variable's name. real :: restart_time character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs - integer :: length + 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 @@ -923,7 +968,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 @@ -931,7 +976,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 @@ -1225,6 +1279,9 @@ subroutine restore_state(filename, directory, day, G, CS) endif enddo + ! Lock the restart registry so that no further variables can be registered. + CS%locked = .true. + end subroutine restore_state !> restart_files_exist determines whether any restart files exist. @@ -1472,8 +1529,8 @@ subroutine restart_init(param_file, CS, restart_root) logical :: rotate_index -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_restart" ! This module's name. logical :: all_default ! If true, all parameters are using their default values. @@ -1545,13 +1602,47 @@ subroutine restart_init(param_file, CS, restart_root) allocate(CS%var_ptr3d(CS%max_fields)) allocate(CS%var_ptr4d(CS%max_fields)) + CS%locked = .false. + end subroutine restart_init -!> Indicate that all variables have now been registered. +!> Issue an error message if the restart_registry is locked. +subroutine lock_check(CS, var_desc, name) + type(MOM_restart_CS), intent(in) :: CS !< A MOM_restart_CS object (intent in) + type(vardesc), optional, intent(in) :: var_desc !< A structure with metadata about this variable + character(len=*), optional, intent(in) :: name !< variable name to be used in the restart file + + character(len=256) :: var_name ! A variable name. + + if (CS%locked) then + if (present(var_desc)) then + call query_vardesc(var_desc, name=var_name) + call MOM_error(FATAL, "Attempted to register "//trim(var_name)//" but the restart registry is locked.") + elseif (present(name)) then + call MOM_error(FATAL, "Attempted to register "//trim(name)//" but the restart registry is locked.") + else + call MOM_error(FATAL, "Attempted to register a variable but the restart registry is locked.") + endif + endif + +end subroutine lock_check + +!> Lock the restart registry so that an error is issued if any further restart variables are registered. +subroutine restart_registry_lock(CS, unlocked) + type(MOM_restart_CS), intent(inout) :: CS !< A MOM_restart_CS object (intent inout) + logical, optional, intent(in) :: unlocked !< If present and true, unlock the registry + + CS%locked = .true. + if (present(unlocked)) CS%locked = .not.unlocked +end subroutine restart_registry_lock + +!> Indicate that all variables have now been registered and lock the registry. subroutine restart_init_end(CS) type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object if (associated(CS)) then + CS%locked = .true. + if (CS%novars == 0) call restart_end(CS) endif 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 fa38e928a0..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,& @@ -1705,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 diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 14cebc90b8..1f8d45e88d 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -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 +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] @@ -93,7 +96,8 @@ module MOM_ice_shelf_dynamics 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]. @@ -128,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 @@ -258,21 +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(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 - ! additional restarts for ice shelf state + 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%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%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 @@ -372,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.) @@ -385,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, & @@ -421,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,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_face_mask_bdry(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_face_mask_bdry(:,:) = -2.0 - allocate( CS%v_face_mask_bdry(Isdq:iedq,Jsdq:Jedq) ) ; CS%v_face_mask_bdry(:,:) = -2.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 @@ -521,6 +531,16 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo call pass_var(CS%calve_mask,G%domain) endif + + ! 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 ) @@ -529,6 +549,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%thickness_bdry_val, G%domain) 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) @@ -2549,11 +2571,13 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) n_g = CS%n_glen; eps_min = CS%eps_glen_min 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) +! 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)) - & @@ -2607,7 +2631,8 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) 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 @@ -3069,7 +3094,8 @@ subroutine ice_shelf_dyn_end(CS) 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) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index c77864f114..f3a5f210fc 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -20,7 +20,8 @@ module MOM_ice_shelf_initialize 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 @@ -512,7 +513,7 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask 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 condiions are read.", & + "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.", & @@ -570,4 +571,100 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask enddo 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..55d7acaff2 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 @@ -1187,7 +1187,7 @@ end function Adcroft_reciprocal !> Initializes the grid masks and any metrics that come with masks already applied. !! !! Initialize_masks sets mask2dT, mask2dCu, mask2dCv, and mask2dBu to mask out -!! flow over any points which are shallower than Dmin and permit an +!! flow over any points which are shallower than Dmask and permit an !! appropriate treatment of the boundary conditions. mask2dCu and mask2dCv !! are 0.0 at any points adjacent to a land point. mask2dBu is 0.0 at !! any land or boundary point. For points in the interior, mask2dCu, @@ -1199,7 +1199,7 @@ subroutine initialize_masks(G, PF, US) ! Local variables real :: m_to_Z_scale ! A unit conversion factor from m to Z. real :: m_to_L ! A unit conversion factor [L m-1 ~> nondim] - real :: Dmin ! The depth for masking in the same units as G%bathyT [Z ~> m]. + real :: Dmask ! The depth for masking in the same units as G%bathyT [Z ~> m]. real :: min_depth ! The minimum ocean depth in the same units as G%bathyT [Z ~> m]. real :: mask_depth ! The depth shallower than which to mask a point as land [Z ~> m]. character(len=40) :: mdl = "MOM_grid_init initialize_masks" @@ -1217,17 +1217,23 @@ 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) - Dmin = min_depth - if (mask_depth>=0.) Dmin = mask_depth + 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 + + Dmask = mask_depth + if (mask_depth == -9999.*m_to_Z_scale) Dmask = min_depth G%mask2dCu(:,:) = 0.0 ; G%mask2dCv(:,:) = 0.0 ; G%mask2dBu(:,:) = 0.0 ! Construct the h-point or T-point mask do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (G%bathyT(i,j) <= Dmin) then + if (G%bathyT(i,j) <= Dmask) then G%mask2dT(i,j) = 0.0 else G%mask2dT(i,j) = 1.0 @@ -1235,7 +1241,7 @@ subroutine initialize_masks(G, PF, US) enddo ; enddo do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 - if ((G%bathyT(i,j) <= Dmin) .or. (G%bathyT(i+1,j) <= Dmin)) then + if ((G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i+1,j) <= Dmask)) then G%mask2dCu(I,j) = 0.0 else G%mask2dCu(I,j) = 1.0 @@ -1243,7 +1249,7 @@ subroutine initialize_masks(G, PF, US) enddo ; enddo do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied - if ((G%bathyT(i,j) <= Dmin) .or. (G%bathyT(i,j+1) <= Dmin)) then + if ((G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i,j+1) <= Dmask)) then G%mask2dCv(i,J) = 0.0 else G%mask2dCv(i,J) = 1.0 @@ -1251,8 +1257,8 @@ subroutine initialize_masks(G, PF, US) enddo ; enddo do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1 - if ((G%bathyT(i+1,j) <= Dmin) .or. (G%bathyT(i+1,j+1) <= Dmin) .or. & - (G%bathyT(i,j) <= Dmin) .or. (G%bathyT(i,j+1) <= Dmin)) then + if ((G%bathyT(i+1,j) <= Dmask) .or. (G%bathyT(i+1,j+1) <= Dmask) .or. & + (G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i,j+1) <= Dmask)) then G%mask2dBu(I,J) = 0.0 else G%mask2dBu(I,J) = 1.0 diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index f12a388897..05bac16710 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -195,8 +195,8 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) character(len=200) :: topo_edits_file, inputdir ! Strings for file/path character(len=40) :: mdl = "apply_topography_edits_from_file" ! This subroutine's name. integer :: i, j, n, ncid, n_edits, i_file, j_file, ndims, sizes(8) - logical :: found logical :: topo_edits_change_mask + real :: min_depth, mask_depth call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") @@ -210,6 +210,17 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) call get_param(param_file, mdl, "ALLOW_LANDMASK_CHANGES", topo_edits_change_mask, & "If true, allow topography overrides to change land mask.", & default=.false.) + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + "If MASKING_DEPTH is unspecified, then anything shallower than "//& + "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out. "//& + "If MASKING_DEPTH is specified, then all depths shallower than "//& + "MINIMUM_DEPTH but deeper than MASKING_DEPTH are rounded to MINIMUM_DEPTH.", & + units="m", default=0.0, scale=m_to_Z) + call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, & + "The depth below which to mask points as land points, for which all "//& + "fluxes are zeroed out. MASKING_DEPTH needs to be smaller than MINIMUM_DEPTH", & + units="m", default=-9999.0, scale=m_to_Z) + if (mask_depth == -9999.*m_to_Z) mask_depth = min_depth if (len_trim(topo_edits_file)==0) return @@ -249,7 +260,7 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) i = ig(n) - G%isd_global + 2 ! +1 for python indexing and +1 for ig-isd_global+1 j = jg(n) - G%jsd_global + 2 if (i>=G%isc .and. i<=G%iec .and. j>=G%jsc .and. j<=G%jec) then - if (new_depth(n)/=0.) then + if (new_depth(n)*m_to_Z /= mask_depth) then write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & 'Ocean topography edit: ', n, ig(n), jg(n), D(i,j)/m_to_Z, '->', abs(new_depth(n)), i, j D(i,j) = abs(m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) @@ -413,17 +424,31 @@ 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. + ! This statement is required for cases with masked-out PEs over the land, + ! to remove the large initialized values (-9e30) from the halos. + D(i,j) = mask_depth endif enddo ; enddo endif @@ -478,11 +503,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 +528,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)//'()') diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 50fd35bae9..c8bc8d27c5 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1420,26 +1420,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 ad32f81f71..592fca4d24 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2545,6 +2545,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) @@ -2561,6 +2562,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) @@ -2625,6 +2627,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 @@ -2656,10 +2659,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 a862dd373d..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 diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 729e961974..fb70f5d679 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -154,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 @@ -1268,12 +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 - 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 @@ -1588,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_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..e122452368 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -16,7 +16,7 @@ module MOM_ALE_sponge use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl -use MOM_domains, only : pass_var +use MOM_domains, only : pass_var use MOM_error_handler, only : MOM_error, FATAL, NOTE, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -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 @@ -706,7 +709,6 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, integer :: nz_data !< the number of vertical levels in this input field character(len=256) :: mesg ! String for error messages ! Local variables for ALE remapping - real, dimension(:), allocatable :: tmpT1d real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. type(remapping_CS) :: remapCS ! Remapping parameters and work arrays @@ -823,13 +825,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 +882,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 +1006,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, & @@ -1004,43 +1018,46 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& answers_2018=CS%hor_regrid_answers_2018) - call pass_var(sp_val,G%Domain) + call pass_var(sp_val, G%Domain) + call pass_var(mask_z, 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) = min(mask_z(i,j,1:nz_data),mask_z(i+1,j,1:nz_data)) enddo ; enddo allocate( hsrc(nz_data) ) - allocate( tmpT1d(nz_data) ) do c=1,CS%num_col_u ! c is an index for the next 3 lines but a multiplier for the rest of the loop ! Therefore we use c as per C code and increment the index where necessary. i = CS%col_i_u(c) ; j = CS%col_j_u(c) - CS%Ref_val_u%p(1:nz_data,c) = sp_val_u(i,j,1:nz_data) + if (mask_u(i,j,1) == 1.0) then + CS%Ref_val_u%p(1:nz_data,c) = sp_val_u(i,j,1:nz_data) + else + CS%Ref_val_u%p(1:nz_data,c) = 0.0 + endif ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0 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 zBottomOfCell = -G%bathyT(i,j) - tmpT1d(k) = tmpT1d(k-1) else ! This next block should only ever be reached over land - tmpT1d(k) = -99.9 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) 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 @@ -1049,29 +1066,31 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& answers_2018=CS%hor_regrid_answers_2018) - call pass_var(sp_val,G%Domain) + call pass_var(sp_val, G%Domain) + call pass_var(mask_z, 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) = min(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) ) - allocate( tmpT1d(nz_data) ) do c=1,CS%num_col_v ! c is an index for the next 3 lines but a multiplier for the rest of the loop ! Therefore we use c as per C code and increment the index where necessary. i = CS%col_i_v(c) ; j = CS%col_j_v(c) - CS%Ref_val_v%p(1:nz_data,c) = sp_val_v(i,j,1:nz_data) + if (mask_v(i,j,1) == 1.0) then + CS%Ref_val_v%p(1:nz_data,c) = sp_val_v(i,j,1:nz_data) + else + CS%Ref_val_v%p(1:nz_data,c) = 0.0 + endif ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0 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 zBottomOfCell = -G%bathyT(i,j) - tmpT1d(k) = tmpT1d(k-1) else ! This next block should only ever be reached over land - tmpT1d(k) = -99.9 endif hsrc(k) = zTopOfCell - zBottomOfCell if (hsrc(k)>0.) nPoints = nPoints + 1 @@ -1081,9 +1100,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) 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 +1302,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_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 9b33e68842..83027914ba 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -231,7 +231,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(group_pass_type) :: pass_hold_eb_ea !< For group halo pass @@ -706,7 +706,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. @@ -1236,9 +1236,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 @@ -1804,7 +1804,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 @@ -2745,8 +2745,8 @@ subroutine adiabatic_driver_init(Time, G, param_file, diag, CS, & type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< pointer to control structure of the !! tracer flow control module -! This "include" declares and sets the variable "version". -#include "version_variable.h" + ! This "include" declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_diabatic_driver" ! This module's name. if (associated(CS)) then @@ -2758,10 +2758,35 @@ subroutine adiabatic_driver_init(Time, G, param_file, diag, CS, & CS%diag => diag if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp -! Set default, read and log parameters + ! Set default, read and log parameters call log_version(param_file, mdl, version, & "The following parameters are used for diabatic processes.") + ! Check for any subsidiary parameters that are inconsistent with the adiabatic mode. + call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified via calls to initialize_sponge and possibly "//& + "set_up_sponge_field.", default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", CS%use_energetic_PBL, & + "If true, use an implied energetics planetary boundary "//& + "layer scheme to determine the diffusivity and viscosity "//& + "in the surface boundary layer.", default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_KPP", CS%use_KPP, & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& + "to calculate diffusivities and non-local transport in the OBL.", & + default=.false., do_not_log=.true.) + + if (CS%use_sponge) call MOM_error(WARNING, & + "When ADIABATIC = True, it is inconsistent to set SPONGE = True.") + if (CS%use_energetic_PBL) call MOM_error(WARNING, & + "When ADIABATIC = True, it is inconsistent to set ENERGETICS_SFC_PBL = True.") + if (CS%use_KPP) call MOM_error(WARNING, & + "When ADIABATIC = True, it is inconsistent to set USE_KPP = True.") + + if (CS%use_sponge .or. CS%use_energetic_PBL .or. CS%use_KPP) & + call MOM_error(FATAL, "adiabatic_driver_init is aborting due to inconsistent parameter settings.") + end subroutine adiabatic_driver_init @@ -2785,13 +2810,14 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di type(sponge_CS), pointer :: sponge_CSp !< pointer to the sponge module control structure type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< pointer to the ALE sponge module control structure + ! Local variables real :: Kd ! A diffusivity used in the default for other tracer diffusivities, in MKS units [m2 s-1] integer :: num_mode logical :: use_temperature character(len=20) :: EN1, EN2, EN3 -! This "include" declares and sets the variable "version". -#include "version_variable.h" + ! This "include" declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_diabatic_driver" ! This module's name. character(len=48) :: thickness_units character(len=40) :: var_name @@ -3084,8 +3110,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 @@ -3286,7 +3310,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) @@ -3359,15 +3383,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 ) @@ -3377,26 +3422,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_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 9e8161441f..7944d4b89f 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -3,7 +3,7 @@ module MOM_geothermal ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : register_static_field, time_type, diag_ctrl use MOM_domains, only : pass_var use MOM_error_handler, only : MOM_error, FATAL, WARNING @@ -23,22 +23,21 @@ module MOM_geothermal !> Control structure for geothermal heating type, public :: geothermal_CS ; private - real :: dRcv_dT_inplace !< The value of dRcv_dT above which (dRcv_dT is - !! negative) the water is heated in place instead - !! of moving upward between layers [R degC-1 ~> kg m-3 degC-1]. - real, pointer :: geo_heat(:,:) => NULL() !< The geothermal heat flux [J m-2 T-1 ~> W m-2]. + real :: dRcv_dT_inplace !< The value of dRcv_dT above which (dRcv_dT is negative) the + !! water is heated in place instead of moving upward between + !! layers in non-ALE layered mode [R degC-1 ~> kg m-3 degC-1] + real, allocatable, dimension(:,:) :: geo_heat !< The geothermal heat flux [J m-2 T-1 ~> W m-2] real :: geothermal_thick !< The thickness over which geothermal heating is - !! applied [H ~> m or kg m-2]. - logical :: apply_geothermal !< If true, geothermal heating will be applied - !! otherwise GEOTHERMAL_SCALE has been set to 0 and - !! there is no heat to apply. - - type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. - type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to - !! regulate the timing of diagnostic output. - integer :: id_internal_heat_heat_tendency = -1 !< ID for diagnostic of heat tendency - integer :: id_internal_heat_temp_tendency = -1 !< ID for diagnostic of temperature tendency - integer :: id_internal_heat_h_tendency = -1 !< ID for diagnostic of thickness tendency + !! applied [H ~> m or kg m-2] + logical :: apply_geothermal !< If true, geothermal heating will be applied. This is false if + !! GEOTHERMAL_SCALE is 0 and there is no heat to apply. + + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the timing + !! timing of diagnostic output + integer :: id_internal_heat_heat_tendency = -1 !< ID for diagnostic of heat tendency + integer :: id_internal_heat_temp_tendency = -1 !< ID for diagnostic of temperature tendency + integer :: id_internal_heat_h_tendency = -1 !< ID for diagnostic of thickness tendency end type geothermal_CS @@ -532,7 +531,7 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS, useALEalgorith CS%apply_geothermal = .not.(geo_scale == 0.0) if (.not.CS%apply_geothermal) return - call safe_alloc_ptr(CS%geo_heat, isd, ied, jsd, jed) ; CS%geo_heat(:,:) = 0.0 + call safe_alloc_alloc(CS%geo_heat, isd, ied, jsd, jed) ; CS%geo_heat(:,:) = 0.0 call get_param(param_file, mdl, "GEOTHERMAL_FILE", geo_file, & "The file from which the geothermal heating is to be "//& @@ -544,7 +543,8 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS, useALEalgorith "The value of drho_dT above which geothermal heating "//& "simply heats water in place instead of moving it between "//& "isopycnal layers. This must be negative.", & - units="kg m-3 K-1", scale=US%kg_m3_to_R, default=-0.01) + units="kg m-3 K-1", scale=US%kg_m3_to_R, default=-0.01, & + do_not_log=((GV%nk_rho_varies<=0).or.(GV%nk_rho_varies>=GV%ke)) ) if (CS%dRcv_dT_inplace >= 0.0) call MOM_error(FATAL, "geothermal_init: "//& "GEOTHERMAL_DRHO_DT_INPLACE must be negative.") @@ -554,8 +554,8 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS, useALEalgorith filename = trim(inputdir)//trim(geo_file) call log_param(param_file, mdl, "INPUTDIR/GEOTHERMAL_FILE", filename) call get_param(param_file, mdl, "GEOTHERMAL_VARNAME", geotherm_var, & - "The name of the geothermal heating variable in "//& - "GEOTHERMAL_FILE.", default="geo_heat") + "The name of the geothermal heating variable in GEOTHERMAL_FILE.", & + default="geo_heat") call MOM_read_data(filename, trim(geotherm_var), CS%geo_heat, G%Domain) do j=jsd,jed ; do i=isd,ied CS%geo_heat(i,j) = (G%mask2dT(i,j) * geo_scale) * CS%geo_heat(i,j) @@ -599,11 +599,9 @@ 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. + if (allocated(CS%geo_heat)) 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 0ede511eb7..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 "//& 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_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 21eb52ebe9..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.) @@ -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 081179eb41..1d46f9aee3 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -121,6 +121,7 @@ module MOM_vert_friction !>@{ Diagnostic identifiers integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 + integer :: id_du_dt_str = -1, id_dv_dt_str = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 integer :: id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 @@ -207,6 +208,8 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: stress ! The surface stress times the time step, divided ! by the density [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: accel_underflow ! An acceleration magnitude that is so small that values that are less + ! than this are diagnosed as 0 [L T-2 ~> m s-2]. real :: zDS, hfr, h_a ! Temporary variables used with direct_stress. real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress ! stress is applied as a body force [H L T-1 ~> m2 s-1 or kg m-1 s-1]. @@ -236,6 +239,8 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & h_neglect = GV%H_subroundoff Idt = 1.0 / dt + accel_underflow = CS%vel_underflow * Idt + !Check if Stokes mixing allowed if requested (present and associated) DoStokesMixing=.false. if (CS%StokesMixing) then @@ -265,9 +270,13 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ADp%du_dt_visc(I,j,k) = u(I,j,k) enddo ; enddo ; endif -! One option is to have the wind stress applied as a body force -! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, -! the wind stress is applied as a stress boundary condition. + if (associated(ADp%du_dt_str)) then ; do k=1,nz ; do I=Isq,Ieq + ADp%du_dt_str(I,j,k) = 0.0 + enddo ; enddo ; endif + + ! One option is to have the wind stress applied as a body force + ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, + ! the wind stress is applied as a stress boundary condition. if (CS%direct_stress) then do I=Isq,Ieq ; if (do_i(I)) then surface_stress(I) = 0.0 @@ -277,6 +286,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & h_a = 0.5 * (h(I,j,k) + h(I+1,j,k)) + h_neglect hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a u(I,j,k) = u(I,j,k) + I_Hmix * hfr * stress + if (associated(ADp%du_dt_str)) ADp%du_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt zDS = zDS + h_a ; if (zDS >= Hmix) exit enddo endif ; enddo ! end of i loop @@ -316,6 +326,8 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u(I,j,2)) d1(I) = b_denom_1 * b1(I) u(I,j,1) = b1(I) * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I)) + if (associated(ADp%du_dt_str)) & + ADp%du_dt_str(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I)*Idt) endif ; enddo do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then c1(I,k) = dt_Z_to_H * CS%a_u(I,j,K) * b1(I) @@ -324,6 +336,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & d1(I) = b_denom_1 * b1(I) u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + & dt_Z_to_H * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I) + if (associated(ADp%du_dt_str)) & + ADp%du_dt_str(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_str(I,j,k) + & + dt_Z_to_H * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1(I) endif ; enddo ; enddo ! back substitute to solve for the new velocities @@ -332,8 +347,17 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & u(I,j,k) = u(I,j,k) + c1(I,k+1) * u(I,j,k+1) endif ; enddo ; enddo ! i and k loops + if (associated(ADp%du_dt_str)) then + do i=is,ie ; if (abs(ADp%du_dt_str(I,j,nz)) < accel_underflow) ADp%du_dt_str(I,j,nz) = 0.0 ; enddo + do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then + ADp%du_dt_str(I,j,k) = ADp%du_dt_str(I,j,k) + c1(I,k+1) * ADp%du_dt_str(I,j,k+1) + if (abs(ADp%du_dt_str(I,j,k)) < accel_underflow) ADp%du_dt_str(I,j,k) = 0.0 + endif ; enddo ; enddo + endif + if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq ADp%du_dt_visc(I,j,k) = (u(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt + if (abs(ADp%du_dt_visc(I,j,k)) < accel_underflow) ADp%du_dt_visc(I,j,k) = 0.0 enddo ; enddo ; endif if (associated(visc%taux_shelf)) then ; do I=Isq,Ieq @@ -373,9 +397,13 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ADp%dv_dt_visc(i,J,k) = v(i,J,k) enddo ; enddo ; endif -! One option is to have the wind stress applied as a body force -! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, -! the wind stress is applied as a stress boundary condition. + if (associated(ADp%dv_dt_str)) then ; do k=1,nz ; do i=is,ie + ADp%dv_dt_str(i,J,k) = 0.0 + enddo ; enddo ; endif + + ! One option is to have the wind stress applied as a body force + ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, + ! the wind stress is applied as a stress boundary condition. if (CS%direct_stress) then do i=is,ie ; if (do_i(i)) then surface_stress(i) = 0.0 @@ -385,6 +413,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & h_a = 0.5 * (h(i,J,k) + h(i,J+1,k)) + h_neglect hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a v(i,J,k) = v(i,J,k) + I_Hmix * hfr * stress + if (associated(ADp%dv_dt_str)) ADp%dv_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt zDS = zDS + h_a ; if (zDS >= Hmix) exit enddo endif ; enddo ! end of i loop @@ -401,6 +430,8 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v(i,J,2)) d1(i) = b_denom_1 * b1(i) v(i,J,1) = b1(i) * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i)) + if (associated(ADp%dv_dt_str)) & + ADp%dv_dt_str(i,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i)*Idt) endif ; enddo do k=2,nz ; do i=is,ie ; if (do_i(i)) then c1(i,k) = dt_Z_to_H * CS%a_v(i,J,K) * b1(i) @@ -408,13 +439,25 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v(i,J,K+1)) d1(i) = b_denom_1 * b1(i) v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt_Z_to_H * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i) + if (associated(ADp%dv_dt_str)) & + ADp%dv_dt_str(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_str(i,J,k) + & + dt_Z_to_H * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1(i) endif ; enddo ; enddo do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then v(i,J,k) = v(i,J,k) + c1(i,k+1) * v(i,J,k+1) endif ; enddo ; enddo ! i and k loops + if (associated(ADp%dv_dt_str)) then + do i=is,ie ; if (abs(ADp%dv_dt_str(i,J,nz)) < accel_underflow) ADp%dv_dt_str(i,J,nz) = 0.0 ; enddo + do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then + ADp%dv_dt_str(i,J,k) = ADp%dv_dt_str(i,J,k) + c1(i,k+1) * ADp%dv_dt_str(i,J,k+1) + if (abs(ADp%dv_dt_str(i,J,k)) < accel_underflow) ADp%dv_dt_str(i,J,k) = 0.0 + endif ; enddo ; enddo + endif + if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie ADp%dv_dt_visc(i,J,k) = (v(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt + if (abs(ADp%dv_dt_visc(i,J,k)) < accel_underflow) ADp%dv_dt_visc(i,J,k) = 0.0 enddo ; enddo ; endif if (associated(visc%tauy_shelf)) then ; do i=is,ie @@ -458,7 +501,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo endif -! Offer diagnostic fields for averaging. + ! Offer diagnostic fields for averaging. if (CS%id_du_dt_visc > 0) & call post_data(CS%id_du_dt_visc, ADp%du_dt_visc, CS%diag) if (CS%id_dv_dt_visc > 0) & @@ -467,6 +510,10 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & call post_data(CS%id_taux_bot, taux_bot, CS%diag) if (present(tauy_bot) .and. (CS%id_tauy_bot > 0)) & call post_data(CS%id_tauy_bot, tauy_bot, CS%diag) + if (CS%id_du_dt_str > 0) & + call post_data(CS%id_du_dt_str, ADp%du_dt_str, CS%diag) + if (CS%id_dv_dt_str > 0) & + call post_data(CS%id_dv_dt_str, ADp%dv_dt_str, CS%diag) ! Diagnostics for terms multiplied by fractional thicknesses @@ -524,10 +571,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & end subroutine vertvisc -!> Calculate the fraction of momentum originally in a layer that remains -!! after a time-step of viscosity, and the fraction of a time-step's -!! worth of barotropic acceleration that a layer experiences after -!! viscosity is applied. +!> Calculate the fraction of momentum originally in a layer that remains in the water column +!! after a time-step of viscosity, equivalently the fraction of a time-step's worth of +!! barotropic acceleration that a layer experiences after viscosity is applied. subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -566,10 +612,8 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo - ! Find the zonal viscous using a modification of a standard tridagonal solver. -!$OMP parallel do default(none) shared(G,Isq,Ieq,CS,nz,visc,dt_Z_to_H,visc_rem_u) & -!$OMP firstprivate(Ray) & -!$OMP private(do_i,b_denom_1,b1,d1,c1) + ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. + !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) do j=G%jsc,G%jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo @@ -597,10 +641,8 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) enddo ! end u-component j loop - ! Now find the meridional viscous using a modification. -!$OMP parallel do default(none) shared(Jsq,Jeq,is,ie,G,CS,visc,dt_Z_to_H,visc_rem_v,nz) & -!$OMP firstprivate(Ray) & -!$OMP private(do_i,b_denom_1,b1,d1,c1) + ! Now find the meridional viscous remnant using the robust tridiagonal solver. + !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo @@ -1813,13 +1855,20 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & '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) + 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) if (CS%id_du_dt_visc > 0) call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) - CS%id_dv_dt_visc = register_diag_field('ocean_model', 'dv_dt_visc', diag%axesCvL, & - Time, 'Meridional Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_dv_dt_visc = register_diag_field('ocean_model', 'dv_dt_visc', diag%axesCvL, Time, & + 'Meridional Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_dv_dt_visc > 0) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + CS%id_du_dt_str = register_diag_field('ocean_model', 'du_dt_str', diag%axesCuL, Time, & + 'Zonal Acceleration from Surface Wind Stresses', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_du_dt_str > 0) call safe_alloc_ptr(ADp%du_dt_str,IsdB,IedB,jsd,jed,nz) + CS%id_dv_dt_str = register_diag_field('ocean_model', 'dv_dt_str', diag%axesCvL, Time, & + 'Meridional Acceleration from Surface Wind Stresses', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_dv_dt_str > 0) call safe_alloc_ptr(ADp%dv_dt_str,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) @@ -1888,7 +1937,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 @@ -1924,14 +1973,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 9977c26016..766d6ae7c8 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -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 @@ -719,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] @@ -772,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 @@ -825,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/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index c56e2ab63f..81444704b3 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -26,7 +26,7 @@ module DOME_initialization public DOME_initialize_topography public DOME_initialize_thickness public DOME_initialize_sponges -public DOME_set_OBC_data +public DOME_set_OBC_data, register_DOME_OBC ! 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 @@ -241,6 +241,30 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) end subroutine DOME_initialize_sponges +!> Add DOME to the OBC registry and set up some variables that will be used to guide +!! code setting up the restart fieldss related to the OBCs. +subroutine register_DOME_OBC(param_file, US, OBC, tr_Reg) + type(param_file_type), intent(in) :: param_file !< parameter file. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer :: OBC !< OBC registry. + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. + + if (OBC%number_of_segments /= 1) then + call MOM_error(FATAL, 'Error in register_DOME_OBC - DOME should have 1 OBC segment', .true.) + endif + + ! Store this information for use in setting up the OBC restarts for tracer reservoirs. + OBC%ntr = tr_Reg%ntr + if (.not. associated(OBC%tracer_x_reservoirs_used)) then + allocate(OBC%tracer_x_reservoirs_used(OBC%ntr)) + allocate(OBC%tracer_y_reservoirs_used(OBC%ntr)) + OBC%tracer_x_reservoirs_used(:) = .false. + OBC%tracer_y_reservoirs_used(:) = .false. + OBC%tracer_y_reservoirs_used(1) = .true. + endif + +end subroutine register_DOME_OBC + !> This subroutine sets the properties of flow at open boundary conditions. !! This particular example is for the DOME inflow describe in Legg et al. 2006. subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) @@ -276,8 +300,8 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) real :: Ri_trans ! The shear Richardson number in the transition ! region of the specified shear profile. character(len=40) :: mdl = "DOME_set_OBC_data" ! This subroutine's name. - character(len=32) :: name - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, NTR + character(len=32) :: name ! The name of a tracer field. + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() type(tracer_type), pointer :: tr_ptr => NULL() @@ -302,22 +326,10 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) return !!! Need a better error message here endif - NTR = tr_Reg%NTR - - ! Stash this information away for the messy tracer restarts. - OBC%ntr = NTR - if (.not. associated(OBC%tracer_x_reservoirs_used)) then - allocate(OBC%tracer_x_reservoirs_used(NTR)) - allocate(OBC%tracer_y_reservoirs_used(NTR)) - OBC%tracer_x_reservoirs_used(:) = .false. - OBC%tracer_y_reservoirs_used(:) = .false. - OBC%tracer_y_reservoirs_used(1) = .true. - endif - segment => OBC%segment(1) if (.not. segment%on_pe) return - allocate(segment%field(NTR)) + allocate(segment%field(tr_Reg%ntr)) do k=1,nz rst = -1.0 @@ -393,9 +405,9 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) call register_segment_tracer(tr_ptr, param_file, GV, & OBC%segment(1), OBC_array=.true.) - ! All tracers but the first have 0 concentration in their inflows. As this - ! is the default value, the following calls are unnecessary. - do m=2,NTR + ! All tracers but the first have 0 concentration in their inflows. As 0 is the + ! default value for the inflow concentrations, the following calls are unnecessary. + do m=2,tr_Reg%ntr if (m < 10) then ; write(name,'("tr_D",I1.1)') m else ; write(name,'("tr_D",I2.2)') m ; endif call tracer_name_lookup(tr_Reg, tr_ptr, name) 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 b9563f9369..38aa6b13a5 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -24,7 +24,7 @@ module MOM_wave_interface #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 @@ -62,6 +62,13 @@ module MOM_wave_interface 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 @@ -80,24 +87,41 @@ module MOM_wave_interface !! 1 if average value of Stokes drift over level. !! If advecting with Stokes transport, 1 is the correct !! approach. + ! 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 - ! Surface Wave Dependent 1d/2d/3d vars 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 :: 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 !< Frequency bands for read/coupled [T-1 ~> s-1] + 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) + La_SL, & !< SL Langmuir number (directionality factored later) !! Horizontal -> H points La_Turb !< Aligned Turbulent Langmuir number [nondim] !! Horizontal -> H points @@ -116,11 +140,6 @@ module MOM_wave_interface !! Horizontal -> V points !! 3rd dimension -> Freq/Wavenumber - ! Pointers to auxiliary fields - 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. - !> An arbitrary lower-bound on the Langmuir number. Run-time parameter. !! Langmuir number is sqrt(u_star/u_stokes). When both are small !! but u_star is orders of magnitude smaller the Langmuir number could @@ -128,6 +147,22 @@ 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 :: id_surfacestokes_x = -1 , id_surfacestokes_y = -1 integer :: id_3dstokes_x = -1 , id_3dstokes_y = -1 @@ -136,63 +171,12 @@ module MOM_wave_interface 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 :: 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 ! 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] -logical :: WaveAgePeakFreq ! Flag to use W -logical :: StaticWaves, DHH85_Is_Set -real :: WaveAge -real :: WaveWind ! Wind speed for the test profile [L T-1 ~> m s-1] -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 @@ -206,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" @@ -217,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 @@ -224,46 +213,65 @@ 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.") endif - CS%g_Earth = US%L_to_Z**2*GV%g_Earth ! Get Wave Method and write to integer WaveMethod call get_param(param_file,mdl,"WAVE_METHOD",TMPSTRING1, & @@ -282,19 +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',& + 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", TP_STKY0,& - 'Surface Stokes (y) for test profile',& + 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", TP_WVL, & + 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"// & @@ -305,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. "// & @@ -321,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 "// & @@ -339,7 +350,7 @@ 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 + 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) @@ -353,40 +364,36 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) 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='m s-1', default=10.0, scale=US%m_s_to_L_T) - call get_param(param_file,mdl,"STATIC_DHH85",StaticWaves, & + 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 @@ -420,46 +427,41 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) 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 (x)', 'm s-1', conversion=US%L_T_to_m_s) - CS%id_La_turb = register_diag_field('ocean_model','La_turbulent',& + 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 @@ -470,12 +472,12 @@ 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 "//& @@ -503,7 +505,7 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) 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 @@ -519,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 @@ -542,6 +543,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) 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 @@ -550,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) @@ -561,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 @@ -574,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 @@ -590,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 @@ -608,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))**2 / CS%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))**2 / CS%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 @@ -633,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))**2 / CS%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 @@ -649,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 @@ -665,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))**2 / CS%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))**2 / CS%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 @@ -690,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))**2 / CS%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 @@ -701,16 +716,16 @@ 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 @@ -743,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 @@ -786,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) @@ -801,28 +828,29 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) 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.dataOverrideIsInitialized) then + if (.not.CS%DataOver_initialized) then call data_override_init(G%Domain) - dataOverrideIsInitialized = .true. + CS%DataOver_initialized = .true. - if (.not.file_exists(SurfBandFileName)) & - call MOM_error(FATAL, "MOM_wave_interface is unable to find file "//trim(SurfBandFileName)) + 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(SurfBandFileName, 'wavenumber', ndims, sizes, dim_names=dim_name) + 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(SurfBandFileName, 'frequency', ndims, sizes, dim_names=dim_name) + 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(SurfBandFileName)//" in MOM_wave_interface.") + trim(CS%SurfBandFileName)//" in MOM_wave_interface.") endif CS%NUMBANDS = sizes(1) @@ -831,23 +859,24 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) if (wavenumber_exists) then ! Wavenumbers found, so this file uses the old method: - PartitionMode = 0 + CS%PartitionMode = 0 ! Reading wavenumber bins - call read_variable(SurfBandFileName, dim_name(1), CS%WaveNum_Cen, scale=US%Z_to_m) + 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: - PartitionMode = 1 + CS%PartitionMode = 1 ! Allocate the frequency bins allocate( CS%Freq_Cen(CS%NUMBANDS) ) ; CS%Freq_Cen(:) = 0.0 ! Reading frequencies - call read_variable(SurfBandFileName, dim_name(1), CS%Freq_Cen, scale=US%T_to_s) + 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))**2 / CS%g_Earth + CS%WaveNum_Cen(b) = CS%Freq_Cen(b)**2 / CS%g_Earth enddo endif @@ -941,9 +970,9 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & ! 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 @@ -964,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)) @@ -972,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)) @@ -982,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)) @@ -991,16 +1020,16 @@ 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, Waves, 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 @@ -1015,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 @@ -1064,11 +1092,18 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) 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 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(ustar*sqrt(GV%Rho0/(1.225*US%kg_m3_to_R)), u10, GV, US, CS) ! surface Stokes drift @@ -1101,8 +1136,15 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) ! surface layer 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 ) * & @@ -1113,6 +1155,30 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) sqrt( 2.0 * PI * kstar * z0) * & erfc( sqrt( 2.0 * kstar * z0 ) ) UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) + + ! 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 @@ -1188,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 @@ -1215,10 +1283,11 @@ subroutine DHH85_mid(GV, US, CS, zpt, UStokes) 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 = WaveWind*US%L_to_Z + u10 = CS%WaveWind*US%L_to_Z !/ omega_min = 0.1*US%T_to_s ! Hz @@ -1228,18 +1297,19 @@ subroutine DHH85_mid(GV, US, CS, zpt, UStokes) domega = (omega_max-omega_min)/real(NOmega) ! - if (WaveAgePeakFreq) then - omega_peak = CS%g_Earth / (WaveAge * u10) + if (CS%WaveAgePeakFreq) then + omega_peak = CS%g_Earth / (CS%WaveAge * u10) else - omega_peak = 2. * pi * 0.13 * CS%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 (WaveAge < 1.) then - Cnn = Cnn - 6.0*log10(WaveAge) + if (CS%WaveAge < 1.) then + Cnn = Cnn - 6.0*log10(CS%WaveAge) endif !/ UStokes = 0.0 @@ -1256,7 +1326,6 @@ subroutine DHH85_mid(GV, US, CS, zpt, UStokes) omega = omega + domega enddo - return end subroutine DHH85_mid !> Explicit solver for Stokes mixing. @@ -1422,7 +1491,7 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) exit endif enddo - return + end subroutine ust_2_u10_coare3p5 !> Clear pointers, deallocate memory @@ -1443,7 +1512,6 @@ subroutine Waves_end(CS) deallocate( CS ) - return end subroutine Waves_end !> \namespace mom_wave_interface 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