diff --git a/.codecov.yml b/.codecov.yml index ae3b27aed3..838c421f66 100644 --- a/.codecov.yml +++ b/.codecov.yml @@ -8,3 +8,6 @@ coverage: default: threshold: 100% base: parent + +fixes: + - "MOM6/::" diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 83d6795954..0f53a68c70 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -23,7 +23,7 @@ runs: run: | echo "::group::config.mk" cd .testing - echo "FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk + echo "FCFLAGS_DEBUG = -g -O0 -std=f2018 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk echo "FCFLAGS_REPRO = -g -O2 -fbacktrace" >> config.mk echo "FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk echo "FCFLAGS_FMS = -g -fbacktrace -O0" >> config.mk diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml index 2d99b45967..ace02ee790 100644 --- a/.github/workflows/coupled-api.yml +++ b/.github/workflows/coupled-api.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 1f5a64ac56..22b9e471bc 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive @@ -19,17 +19,11 @@ jobs: - uses: ./.github/actions/testing-setup - - name: Compile file parser unit tests - run: make -j build/unit/test_MOM_file_parser - - - name: Run file parser unit tests - run: make run.cov.unit - - - name: Compile unit testing + - name: Compile unit tests run: make -j build.unit - - name: Run (single processor) unit tests - run: make run.unit + - name: Run unit tests + run: make run.cov.unit - name: Report unit test coverage to CI run: make report.cov.unit @@ -40,7 +34,7 @@ jobs: run: make -j build/cov/MOM6 - name: Run coverage tests - run: make -j -k run.cov + run: make -k run.cov - name: Report coverage to CI run: make report.cov diff --git a/.github/workflows/documentation-and-style.yml b/.github/workflows/documentation-and-style.yml index 3ca7f0e613..857db917b6 100644 --- a/.github/workflows/documentation-and-style.yml +++ b/.github/workflows/documentation-and-style.yml @@ -8,7 +8,7 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/expression.yml b/.github/workflows/expression.yml index 5860d32e37..3cd19ee18c 100644 --- a/.github/workflows/expression.yml +++ b/.github/workflows/expression.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/macos-regression.yml b/.github/workflows/macos-regression.yml index d769e15131..16e2e15f80 100644 --- a/.github/workflows/macos-regression.yml +++ b/.github/workflows/macos-regression.yml @@ -17,7 +17,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/macos-stencil.yml b/.github/workflows/macos-stencil.yml index 6e77a5c4a6..a30ad17199 100644 --- a/.github/workflows/macos-stencil.yml +++ b/.github/workflows/macos-stencil.yml @@ -17,7 +17,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/other.yml b/.github/workflows/other.yml index 2cba17ae76..9a941bafa9 100644 --- a/.github/workflows/other.yml +++ b/.github/workflows/other.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/perfmon.yml b/.github/workflows/perfmon.yml index 8fd314cee3..a66ba90643 100644 --- a/.github/workflows/perfmon.yml +++ b/.github/workflows/perfmon.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/regression.yml b/.github/workflows/regression.yml index 7cdd0a5cd6..107948d5da 100644 --- a/.github/workflows/regression.yml +++ b/.github/workflows/regression.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/stencil.yml b/.github/workflows/stencil.yml index c85945072c..d46da6e4fa 100644 --- a/.github/workflows/stencil.yml +++ b/.github/workflows/stencil.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 55494696ae..39512c0dd1 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,7 +9,7 @@ stages: # that is unique to this pipeline. # We use the "fetch" strategy to speed up the startup of stages variables: - JOB_DIR: "/gpfs/f5/gfdl_o/scratch/oar.gfdl.ogrp-account/runner/builds/$CI_PIPELINE_ID" + JOB_DIR: "/gpfs/f5/gfdl_o/scratch/oar.gfdl.mom6-account/runner/builds/$CI_PIPELINE_ID" GIT_STRATEGY: fetch # Always eport value of $JOB_DIR @@ -20,7 +20,7 @@ before_script: p:merge: stage: setup tags: - - ncrc5 + - mom6-ci-c5 script: - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl @@ -30,7 +30,7 @@ p:merge: p:clone: stage: setup tags: - - ncrc5 + - mom6-ci-c5 script: # NOTE: We could sweep any builds older than 3 days here if needed #- find $HOME/ci/[0-9]* -mtime +3 -delete 2> /dev/null || true @@ -45,7 +45,7 @@ p:clone: s:work-space:pgi: stage: setup tags: - - ncrc5 + - mom6-ci-c5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space pgi @@ -53,7 +53,7 @@ s:work-space:pgi: s:work-space:intel: stage: setup tags: - - ncrc5 + - mom6-ci-c5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space intel @@ -61,7 +61,7 @@ s:work-space:intel: s:work-space:gnu: stage: setup tags: - - ncrc5 + - mom6-ci-c5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space gnu @@ -69,7 +69,7 @@ s:work-space:gnu: s:work-space:gnu-restarts: stage: setup tags: - - ncrc5 + - mom6-ci-c5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space gnu-rst @@ -83,7 +83,7 @@ compile:pgi:repro: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile repro_pgi @@ -91,7 +91,7 @@ compile:intel:repro: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile repro_intel @@ -99,7 +99,7 @@ compile:gnu:repro: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile repro_gnu mrs-compile static_gnu @@ -107,7 +107,7 @@ compile:gnu:debug: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile debug_gnu @@ -115,7 +115,7 @@ compile:gnu:ocean-only-nolibs: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh nolibs-ocean-only-compile gnu @@ -123,7 +123,7 @@ compile:gnu:ice-ocean-nolibs: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh nolibs-ocean-ice-compile gnu @@ -133,36 +133,36 @@ run:pgi: stage: run needs: ["s:work-space:pgi","compile:pgi:repro"] tags: - - ncrc5 + - mom6-ci-c5 script: - - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_pgi_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite pgi SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=${MOM6_RUN_JOB_DURATION:=15:00} --account=gfdl_o --qos=debug --job-name=mom6_pgi_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite pgi SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-pgi-SNL || ( echo Batch job did not complete ; exit 911 ) run:intel: stage: run needs: ["s:work-space:intel","compile:intel:repro"] tags: - - ncrc5 + - mom6-ci-c5 script: - - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_intel_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite intel SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=${MOM6_RUN_JOB_DURATION:=15:00} --account=gfdl_o --qos=debug --job-name=mom6_intel_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite intel SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-intel-SNL || ( echo Batch job did not complete ; exit 911 ) run:gnu: stage: run needs: ["s:work-space:gnu","compile:gnu:repro","compile:gnu:debug"] tags: - - ncrc5 + - mom6-ci-c5 script: - - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu SNLDT && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=${MOM6_RUN_JOB_DURATION:=15:00} --account=gfdl_o --qos=debug --job-name=mom6_gnu_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu SNLDT && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-gnu-SNLDT || ( echo Batch job did not complete ; exit 911 ) run:gnu-restarts: stage: run needs: ["s:work-space:gnu-restarts","compile:gnu:repro"] tags: - - ncrc5 + - mom6-ci-c5 script: - - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_restarts --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu R && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=${MOM6_RUN_JOB_DURATION:=15:00} --account=gfdl_o --qos=debug --job-name=mom6_gnu_restarts --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu R && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-gnu-R || ( echo Batch job did not complete ; exit 911 ) # GH/autoconf tests (duplicates the GH actions tests) @@ -174,7 +174,7 @@ actions:gnu: stage: tests needs: [] tags: - - ncrc5 + - mom6-ci-c5 before_script: - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" - git submodule init ; git submodule update @@ -182,9 +182,9 @@ actions:gnu: script: - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - - module unload PrgEnv-gnu PrgEnv-intel PrgEnv-nvhpc ; module load PrgEnv-gnu ; module unload gcc ; module load gcc/12.2.0 cray-hdf5 cray-netcdf - - make -s -j - - MPIRUN= make preproc -s -j + - module unload darshan-runtime intel PrgEnv-intel ; module load PrgEnv-gnu/8.5.0 cray-hdf5 cray-netcdf ; module switch gcc-native/12.3 + - FC=ftn MPIFC=ftn CC=cc make -s -j + - MPIRUN= FC=ftn MPIFC=ftn CC=cc make preproc -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make test -s @@ -194,7 +194,7 @@ actions:intel: stage: tests needs: [] tags: - - ncrc5 + - mom6-ci-c5 before_script: - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" - git submodule init ; git submodule update @@ -202,9 +202,9 @@ actions:intel: 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 ; module load PrgEnv-intel; module unload intel; module load intel-classic/2022.0.2 cray-hdf5 cray-netcdf - - make -s -j - - MPIRUN= make preproc -s -j + - module unload darshan-runtime ; module unload intel cray-libsci cray-mpich PrgEnv-intel ; module load PrgEnv-intel intel/2023.2.0 cray-hdf5 cray-netcdf cray-mpich + - FC=ftn MPIFC=ftn CC=cc make -s -j + - MPIRUN= FC=ftn MPIFC=ftn CC=cc make preproc -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.intel.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make test -s @@ -219,7 +219,7 @@ t:pgi:symmetric: stage: tests needs: ["run:pgi"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats pgi S @@ -227,7 +227,7 @@ t:pgi:non-symmetric: stage: tests needs: ["run:pgi"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats pgi N @@ -235,7 +235,7 @@ t:pgi:layout: stage: tests needs: ["run:pgi"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats pgi L @@ -243,7 +243,7 @@ t:pgi:params: stage: tests needs: ["run:pgi"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-params pgi allow_failure: true @@ -252,7 +252,7 @@ t:intel:symmetric: stage: tests needs: ["run:intel"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats intel S @@ -260,7 +260,7 @@ t:intel:non-symmetric: stage: tests needs: ["run:intel"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats intel N @@ -268,7 +268,7 @@ t:intel:layout: stage: tests needs: ["run:intel"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats intel L @@ -276,7 +276,7 @@ t:intel:params: stage: tests needs: ["run:intel"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-params intel allow_failure: true @@ -285,7 +285,7 @@ t:gnu:symmetric: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu S @@ -293,7 +293,7 @@ t:gnu:non-symmetric: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu N @@ -301,7 +301,7 @@ t:gnu:layout: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu L @@ -309,7 +309,7 @@ t:gnu:static: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu T @@ -317,7 +317,7 @@ t:gnu:symmetric-debug: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu D @@ -325,7 +325,7 @@ t:gnu:restart: stage: tests needs: ["run:gnu-restarts"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu R @@ -333,7 +333,7 @@ t:gnu:params: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-params gnu allow_failure: true @@ -342,7 +342,7 @@ t:gnu:diags: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-diags gnu allow_failure: true @@ -351,7 +351,7 @@ t:gnu:diags: cleanup: stage: cleanup tags: - - ncrc5 + - mom6-ci-c5 before_script: - echo Skipping usual preamble script: diff --git a/.testing/Makefile b/.testing/Makefile index f5da44342d..a8a5ea3e68 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -83,19 +83,21 @@ export FMS_URL # TODO: This needs more automated configuration MPIRUN ?= mpirun -# Generic compiler variables are pass through to the builds +# Generic compiler variables are passed through to the builds export CC export MPICC export FC export MPIFC # Builds are distinguished by FCFLAGS -FCFLAGS_DEBUG ?= -g -O0 +FCFLAGS ?= -g -O0 + +FCFLAGS_DEBUG ?= $(FCFLAGS) FCFLAGS_REPRO ?= -g -O2 FCFLAGS_OPT ?= -g -O3 -mavx -fno-omit-frame-pointer FCFLAGS_INIT ?= FCFLAGS_COVERAGE ?= -g -O0 -fbacktrace --coverage -FCFLAGS_FMS ?= $(FCFLAGS_DEBUG) +FCFLAGS_FMS ?= $(FCFLAGS) # Additional notes: # - These default values are simple, minimalist flags, supported by nearly all # compilers, and are somewhat analogous to GFDL's DEBUG and REPRO builds. @@ -220,8 +222,6 @@ build.prof: $(foreach b,opt opt_target,$(BUILD)/$(b)/MOM6) # Compiler flags # .testing dependencies -# TODO: We should probably build TARGET with the FMS that it was configured -# to use. But for now we use the same FMS over all builds. FCFLAGS_DEPS = -I$(abspath $(DEPS)/include) LDFLAGS_DEPS = -L$(abspath $(DEPS)/lib) PATH_DEPS = PATH="${PATH}:$(abspath $(DEPS)/bin)" @@ -265,10 +265,12 @@ $(BUILD)/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests # Build executables +.NOTPARALLEL:$(foreach e,$(UNIT_EXECS),$(BUILD)/unit/$(e)) $(BUILD)/unit/test_%: $(BUILD)/unit/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -j $(BUILD)/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) +.NOTPARALLEL:$(foreach e,$(TIMING_EXECS),$(BUILD)/timing/$(e)) $(BUILD)/timing/time_%: $(BUILD)/timing/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -j $(BUILD)/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) @@ -278,7 +280,7 @@ $(BUILD)/%/MOM6: $(BUILD)/%/Makefile FORCE # Target codebase should use its own build system $(BUILD)/target/MOM6: $(BUILD)/target FORCE | $(TARGET_CODEBASE) - $(MAKE) -C $(TARGET_CODEBASE)/.testing build/symmetric/MOM6 + $(MAKE) -C $(TARGET_CODEBASE)/.testing BUILD=build build/symmetric/MOM6 $(BUILD)/target: | $(TARGET_CODEBASE) ln -s $(abspath $(TARGET_CODEBASE))/.testing/build/symmetric $@ @@ -649,7 +651,7 @@ $(WORK)/%/restart/ocean.stats: $(BUILD)/symmetric/MOM6 | preproc # Not a true rule; only call this after `make test` to summarize test results. .PHONY: test.summary test.summary: - @./tools/report_test_results.sh $(WORK)/results + ./tools/report_test_results.sh $(WORK)/results #--- @@ -657,7 +659,7 @@ test.summary: # NOTE: Using file parser gcov report as a proxy for test completion .PHONY: run.cov.unit -run.cov.unit: $(BUILD)/unit/MOM_file_parser_tests.F90.gcov +run.cov.unit: $(foreach t,$(UNIT_EXECS),$(BUILD)/unit/$(t).F90.gcov) .PHONY: build.unit build.unit: $(foreach f, $(UNIT_EXECS), $(BUILD)/unit/$(f)) @@ -698,6 +700,7 @@ $(WORK)/unit/%.out: $(BUILD)/unit/% @mkdir -p $(@D) cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> >(tee $*.err) > $*.out +# The file parser uses a separate rule to support two-core tests. $(WORK)/unit/test_MOM_file_parser.out: $(BUILD)/unit/test_MOM_file_parser if [ $(REPORT_COVERAGE) ]; then \ find $(BUILD)/unit -name *.gcda -exec rm -f '{}' \; ; \ @@ -717,15 +720,13 @@ $(WORK)/unit/test_MOM_file_parser.out: $(BUILD)/unit/test_MOM_file_parser cat p2.test_MOM_file_parser.err | tail -n 100 ; \ ) -# NOTE: .gcov actually depends on .gcda, but .gcda is produced with std.out -# TODO: Replace $(WORK)/unit/std.out with *.gcda? -$(BUILD)/unit/MOM_file_parser_tests.F90.gcov: $(WORK)/unit/test_MOM_file_parser.out +$(BUILD)/unit/test_%.F90.gcov: $(WORK)/unit/test_%.out cd $(@D) \ && gcov -b *.gcda > gcov.unit.out find $(@D) -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; .PHONY: report.cov.unit -report.cov.unit: $(BUILD)/unit/MOM_file_parser_tests.F90.gcov codecov +report.cov.unit: $(foreach t,$(UNIT_EXECS),$(BUILD)/unit/$(t).F90.gcov) codecov ./codecov $(CODECOV_TOKEN_ARG) -R $(BUILD)/unit -f "*.gcov" -Z -n "Unit tests" \ > $(BUILD)/unit/codecov.out \ 2> $(BUILD)/unit/codecov.err \ diff --git a/.testing/tc0/MOM_input b/.testing/tc0/MOM_input index e4d1694e72..7a107486b2 100644 --- a/.testing/tc0/MOM_input +++ b/.testing/tc0/MOM_input @@ -13,6 +13,9 @@ ADIABATIC = True ! [Boolean] default = False ! true. This assumes that KD = KDML = 0.0 and that ! there is no buoyancy forcing, but makes the model ! faster by eliminating subroutine calls. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 8.64E+04 ! [s] ! The (baroclinic) dynamics time step. The time-step that ! is actually used will be an integer fraction of the diff --git a/.testing/tc1/MOM_input b/.testing/tc1/MOM_input index 151c093ff9..098952ccc2 100644 --- a/.testing/tc1/MOM_input +++ b/.testing/tc1/MOM_input @@ -72,6 +72,9 @@ MIXEDLAYER_RESTRAT = True ! [Boolean] default = False ! If true, a density-gradient dependent re-stratifying ! flow is imposed in the mixed layer. ! This is only used if BULKMIXEDLAYER is true. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 900.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that ! is actually used will be an integer fraction of the @@ -278,6 +281,12 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! have no effect on the SADOURNY Coriolis scheme if it ! were possible to use centered difference thickness fluxes. +! === module MOM_PressureForce_FV === +MASS_WEIGHT_IN_PRESSURE_GRADIENT = True ! [Boolean] default = False + ! If true, use mass weighting when interpolating T/S for integrals + ! near the bathymetry in FV pressure gradient calculations. + + ! === module MOM_hor_visc === AH_VEL_SCALE = 0.05 ! [m s-1] default = 0.0 ! The velocity scale which is multiplied by the cube of diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index c7d2a35aa6..c8aad58e92 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -75,6 +75,9 @@ MIXEDLAYER_RESTRAT = True ! [Boolean] default = False ! If true, a density-gradient dependent re-stratifying ! flow is imposed in the mixed layer. ! This is only used if BULKMIXEDLAYER is true. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 3600.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that ! is actually used will be an integer fraction of the @@ -302,11 +305,16 @@ PGF_STANLEY_T2_DET_COEFF = -1.0 ! [nondim] default = -1.0 ! gradient in the deterministic part of the Stanley form of the Brankart ! correction. Negative values disable the scheme. +! === module MOM_PressureForce_FV === +MASS_WEIGHT_IN_PRESSURE_GRADIENT = True ! [Boolean] default = False + ! If true, use mass weighting when interpolating T/S for integrals + ! near the bathymetry in FV pressure gradient calculations. + ! === module MOM_hor_visc === LAPLACIAN = True KH_VEL_SCALE = 0.05 SMAGORINSKY_KH = True ! [Boolean] default = False -SMAG_LAP_CONST = 0.06 ! [nondim] default = 0.0 +SMAG_LAP_CONST = 0.06 ! [nondim] default = 0.0 AH_VEL_SCALE = 0.05 ! [m s-1] default = 0.0 ! The velocity scale which is multiplied by the cube of ! the grid spacing to calculate the Laplacian viscosity. diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index 6963feee98..6a1238ee96 100644 --- a/.testing/tc3/MOM_input +++ b/.testing/tc3/MOM_input @@ -72,6 +72,9 @@ NK = 10 ! [nondim] ENABLE_THERMODYNAMICS = False ! [Boolean] default = True ! If true, Temperature and salinity are used as state ! variables. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 120.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that ! is actually used will be an integer fraction of the diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input index 591ed4c788..b985b8e082 100644 --- a/.testing/tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -4,6 +4,9 @@ USE_REGRIDDING = True ! [Boolean] default = False ! If True, use the ALE algorithm (regridding/remapping). If False, use the ! layered isopycnal algorithm. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 1200.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that is actually used will ! be an integer fraction of the forcing time-step (DT_FORCING in ocean-only mode @@ -269,6 +272,9 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! === module MOM_PressureForce === ! === module MOM_PressureForce_FV === +MASS_WEIGHT_IN_PRESSURE_GRADIENT = True ! [Boolean] default = False + ! If true, use mass weighting when interpolating T/S for integrals + ! near the bathymetry in FV pressure gradient calculations. RECONSTRUCT_FOR_PRESSURE = False ! [Boolean] default = True ! If True, use vertical reconstruction of T & S within the integrals of the FV ! pressure gradient calculation. If False, use the constant-by-layer algorithm. diff --git a/.testing/tools/parse_perf.py b/.testing/tools/parse_perf.py index 76c6be5bcb..efcfa13b4f 100755 --- a/.testing/tools/parse_perf.py +++ b/.testing/tools/parse_perf.py @@ -102,7 +102,7 @@ def parse_perf_report(perf_data_path): if tok == '>': bracks -= 1 - if tok == '(': + if tok == ')': parens -= 1 # Strip any whitespace tokens diff --git a/ac/configure.ac b/ac/configure.ac index 8196e2eb01..071f43f5a9 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -81,8 +81,8 @@ AS_IF([test "x$with_driver" != "x"], # Explicitly assume free-form Fortran -AC_LANG(Fortran) -AC_FC_SRCEXT(f90) +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) # Determine MPI compiler wrappers diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac index a52533970b..7d68daa3c7 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -10,7 +10,16 @@ AC_INIT( AC_CONFIG_SRCDIR([fms/fms.F90]) AC_CONFIG_MACRO_DIR([m4]) + # C configuration + +# Autoconf assumes that LDFLAGS can be passed to CFLAGS, even though this is +# not valid in some compilers. This can cause basic CC tests to fail. +# Since we do not link with CC, we can safely disable LDFLAGS for AC_PROG_CC. +FC_LDFLAGS="$LDFLAGS" +LDFLAGS="" + +# C compiler verification AC_PROG_CC AX_MPI CC=$MPICC @@ -55,10 +64,13 @@ AC_CHECK_FUNCS([gettid], [], [ # FMS 2019.01.03 uses __APPLE__ to disable Linux CPU affinity calls. AC_CHECK_FUNCS([sched_getaffinity], [], [AC_DEFINE([__APPLE__])]) +# Restore LDFLAGS +LDFLAGS="$FC_LDFLAGS" + # Standard Fortran configuration -AC_LANG(Fortran) -AC_FC_SRCEXT(f90) +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) AC_PROG_FC diff --git a/ac/makedep b/ac/makedep index e0d350857e..3ae3567d20 100755 --- a/ac/makedep +++ b/ac/makedep @@ -214,68 +214,91 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, # Create new makefile with open(makefile, 'w') as file: print("# %s created by makedep" % (makefile), file=file) - print("", file=file) + print(file=file) print("# Invoked as", file=file) print('# '+' '.join(sys.argv), file=file) - print("", file=file) + print(file=file) print("all:", " ".join(targets), file=file) - print("", file=file) + # print(file=file) # print("# SRC_DIRS is usually set in the parent Makefile but in case is it not we", file=file) # print("# record it here from when makedep was previously invoked.", file=file) # print("SRC_DIRS ?= ${SRC_DIRS}", file=file) - # print("", file=file) + # print(file=file) # print("# all_files:", ' '.join(all_files), file=file) - # print("", file=file) # Write rule for each object from Fortran - for o in sorted(o2F90.keys()): - found_mods = [m for m in o2uses[o] if m in all_modules] - found_objs = [mod2o[m] for m in o2uses[o] if m in all_modules] + for obj in sorted(o2F90.keys()): + found_mods = [m for m in o2uses[obj] if m in all_modules] + found_objs = [mod2o[m] for m in o2uses[obj] if m in all_modules] found_deps = [ dep for pair in zip(found_mods, found_objs) for dep in pair ] - missing_mods = [m for m in o2uses[o] if m not in all_modules] + missing_mods = [m for m in o2uses[obj] if m not in all_modules] - incs, inc_used = nested_inc(o2h[o] + o2inc[o], f2F, defines) - inc_mods = [u for u in inc_used if u not in found_mods and u in all_modules] + incs, inc_used = nested_inc(o2h[obj] + o2inc[obj], f2F, defines) + inc_mods = [ + u for u in inc_used if u not in found_mods and u in all_modules + ] incdeps = sorted(set([f2F[f] for f in incs if f in f2F])) - incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) + incargs = sorted(set(['-I' + os.path.dirname(f) for f in incdeps])) + + # Header + print(file=file) if debug: - print("# Source file {} produces:".format(o2F90[o]), file=file) - print("# object:", o, file=file) - print("# modules:", ' '.join(o2mods[o]), file=file) - print("# uses:", ' '.join(o2uses[o]), file=file) + print("# Source file {} produces:".format(o2F90[obj]), file=file) + print("# object:", obj, file=file) + print("# modules:", ' '.join(o2mods[obj]), file=file) + print("# uses:", ' '.join(o2uses[obj]), file=file) print("# found mods:", ' '.join(found_mods), file=file) print("# found objs:", ' '.join(found_objs), file=file) print("# missing:", ' '.join(missing_mods), file=file) print("# includes_all:", ' '.join(incs), file=file) print("# includes_pth:", ' '.join(incdeps), file=file) print("# incargs:", ' '.join(incargs), file=file) - print("# program:", ' '.join(o2prg[o]), file=file) - if o2mods[o]: - print(' '.join(o2mods[o])+':', o, file=file) - print(o + ':', o2F90[o], ' '.join(inc_mods + incdeps + found_deps), file=file) - print('\t'+fc_rule, ' '.join(incargs), file=file) + print("# program:", ' '.join(o2prg[obj]), file=file) + + # Fortran Module dependencies + if o2mods[obj]: + print(' '.join(o2mods[obj]) + ':', obj, file=file) + + # Fortran object dependencies + obj_incs = ' '.join(inc_mods + incdeps + found_deps) + print(obj + ':', o2F90[obj], obj_incs, file=file) + + # Fortran object build rule + obj_rule = ' '.join([fc_rule] + incargs + ['-c', '$<']) + print('\t' + obj_rule, file=file) # Write rule for each object from C - for o in sorted(o2c.keys()): - incdeps = sorted(set([f2F[h] for h in o2h[o] if h in f2F])) - incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) + for obj in sorted(o2c.keys()): + incdeps = sorted(set([f2F[h] for h in o2h[obj] if h in f2F])) + incargs = sorted(set(['-I' + os.path.dirname(f) for f in incdeps])) + + # Header + print(file=file) if debug: - print("# Source file %s produces:" % (o2c[o]), file=file) - print("# object:", o, file=file) - print("# includes_all:", ' '.join(o2h[o]), file=file) + print("# Source file %s produces:" % (o2c[obj]), file=file) + print("# object:", obj, file=file) + print("# includes_all:", ' '.join(o2h[obj]), file=file) print("# includes_pth:", ' '.join(incdeps), file=file) print("# incargs:", ' '.join(incargs), file=file) - print(o+':', o2c[o], ' '.join(incdeps), file=file) - print('\t$(CC) $(DEFS) $(CPPFLAGS) $(CFLAGS) -c $<', ' '.join(incargs), file=file) + + # C object dependencies + print(obj + ':', o2c[obj], ' '.join(incdeps), file=file) + + # C object build rule + c_rule = ' '.join( + ['$(CC) $(DEFS) $(CPPFLAGS) $(CFLAGS)'] + incargs + ['-c', '$<'] + ) + #print('\t' + c_rule, ' '.join(incargs), '-c', '$<', file=file) + print('\t' + c_rule, file=file) # Externals (so called) if link_externals: - print("", file=file) + print(file=file) print("# Note: The following object files are not associated with " "modules so we assume we should link with them:", file=file) print("# ", ' '.join(externals), file=file) @@ -286,23 +309,23 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, # Write rules for linking executables for p in sorted(prg2o.keys()): o = prg2o[p] - print("", file=file) + print(file=file) print(p+':', ' '.join(link_obj(o, o2uses, mod2o, all_modules) + externals), file=file) print('\t$(LD) $(LDFLAGS) -o $@ $^ $(LIBS)', file=file) # Write rules for building libraries for lb in sorted(targ_libs): - print("", file=file) + print(file=file) print(lb+':', ' '.join(list(o2F90.keys()) + list(o2c.keys())), file=file) print('\t$(AR) $(ARFLAGS) $@ $^', file=file) # Write cleanup rules - print("", file=file) + print(file=file) print("clean:", file=file) print('\trm -f *.mod *.o', ' '.join(list(prg2o.keys()) + targ_libs), file=file) # Write re-generation rules - print("", file=file) + print(file=file) print("remakedep:", file=file) print('\t'+' '.join(sys.argv), file=file) @@ -366,7 +389,6 @@ def scan_fortran_file(src_file, defines=None): cpp_defines = defines if defines is not None else [] - #cpp_macros = [define.split('=')[0] for define in cpp_defines] cpp_macros = dict([t.split('=') for t in cpp_defines]) cpp_group_stack = [] @@ -374,16 +396,16 @@ def scan_fortran_file(src_file, defines=None): lines = file.readlines() external_namespace = True - # True if we are in the external (i.e. global) namespace + # True if we are in the external (i.e. global) namespace file_has_externals = False - # True if the file contains any external objects + # True if the file contains any external objects cpp_exclude = False - # True if the parser excludes the subsequent lines + # True if the parser excludes the subsequent lines cpp_group_stack = [] - # Stack of condition group exclusion states + # Stack of condition group exclusion states for line in lines: # Start of #ifdef condition group @@ -446,14 +468,16 @@ def scan_fortran_file(src_file, defines=None): if match: new_macro = line.lstrip()[1:].split()[1] try: - cpp_macros.remove(new_macro) - except: - # Ignore missing macros (for now?) + cpp_macros.pop(new_macro) + except KeyError: + # C99: "[A macro] is ignored if the specified identifier is + # not currently defined as a macro name." continue match = re_module.match(line.lower()) if match: - if match.group(1) not in 'procedure': # avoid "module procedure" statements + # Avoid "module procedure" statements + if match.group(1) not in 'procedure': module_decl.append(match.group(1)) external_namespace = False @@ -632,9 +656,9 @@ parser.add_argument( ) parser.add_argument( '-f', '--fc_rule', - default="$(FC) $(DEFS) $(FCFLAGS) $(CPPFLAGS) -c $<", + default="$(FC) $(DEFS) $(CPPFLAGS) $(FCFLAGS)", help="String to use in the compilation rule. Default is: " - "'$(FC) $(DEFS) $(FCFLAGS) $(CPPFLAGS) -c $<'" + "'$(FC) $(DEFS) $(CPPFLAGS) $(FCFLAGS)'" ) parser.add_argument( '-x', '--exec_target', 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 97d3742749..b686c59a1f 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -635,9 +635,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif ! Set the wind stresses and ustar. - if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) .and. associated(fluxes%tau_mag)) then + if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) .and. associated(fluxes%tau_mag) & + .and. associated(fluxes%tau_mag_gustless) ) then call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar, & - mag_tau=fluxes%tau_mag, gustless_ustar=fluxes%ustar_gustless) + mag_tau=fluxes%tau_mag, gustless_ustar=fluxes%ustar_gustless, & + gustless_mag_tau=fluxes%tau_mag_gustless) else if (associated(fluxes%ustar)) & call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar) @@ -645,6 +647,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_ustar=fluxes%ustar_gustless) if (associated(fluxes%tau_mag)) & call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=fluxes%tau_mag) + if (associated(fluxes%tau_mag_gustless)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_mag_tau=fluxes%tau_mag_gustless) endif if (coupler_type_initialized(fluxes%tr_fluxes) .and. & @@ -908,7 +912,7 @@ end subroutine convert_IOB_to_forces !! Ice_ocean_boundary_type into optional argument arrays, including changes of units, sign !! conventions, and putting the fields into arrays with MOM-standard sized halos. subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ustar, & - gustless_ustar, mag_tau, tau_halo) + gustless_ustar, mag_tau, gustless_mag_tau, tau_halo) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model @@ -931,6 +935,9 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, real, dimension(SZI_(G),SZJ_(G)), & optional, intent(inout) :: mag_tau !< The magintude of the wind stress at tracer points !! including subgridscale variability and gustiness [R Z L T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: gustless_mag_tau !< The magintude of the wind stress at tracer points + !! without any contributions from gustiness [R Z L T-2 ~> Pa] integer, optional, intent(in) :: tau_halo !< The halo size of wind stresses to set, 0 by default. ! Local variables @@ -947,7 +954,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, real :: tau_mag ! magnitude of the wind stress [R Z L T-2 ~> Pa] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] - logical :: do_ustar, do_gustless, do_tau_mag + logical :: do_ustar, do_gustless, do_tau_mag, do_gustless_tau_mag integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) integer :: i, j, is, ie, js, je, ish, ieh, jsh, jeh, Isqh, Ieqh, Jsqh, Jeqh, i0, j0, halo @@ -960,7 +967,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, IRho0 = US%L_to_Z / CS%Rho0 stress_conversion = US%Pa_to_RLZ_T2 * CS%wind_stress_multiplier - do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) ; do_tau_mag = present(mag_tau) + do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) + do_tau_mag = present(mag_tau) ; do_gustless_tau_mag = present(gustless_mag_tau) wind_stagger = CS%wind_stagger if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & @@ -973,7 +981,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ! Set surface momentum stress related fields as a function of staggering. if (present(taux) .or. present(tauy) .or. & - ((do_ustar .or. do_tau_mag .or. do_gustless) .and. .not.associated(IOB%stress_mag)) ) then + ((do_ustar .or. do_tau_mag .or. do_gustless .or. do_gustless_tau_mag) & + .and. .not.associated(IOB%stress_mag)) ) then if (wind_stagger == BGRID_NE) then taux_in_B(:,:) = 0.0 ; tauy_in_B(:,:) = 0.0 @@ -1053,7 +1062,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, endif ! endif for extracting wind stress fields with various staggerings endif - if (do_ustar .or. do_tau_mag .or. do_gustless) then + if (do_ustar .or. do_tau_mag .or. do_gustless .or. do_gustless_tau_mag) then ! Set surface friction velocity directly or as a function of staggering. ! ustar is required for the bulk mixed layer formulation and other turbulent mixing ! parametizations. The background gustiness (for example with a relatively small value @@ -1071,6 +1080,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, endif if (do_tau_mag) & mag_tau(i,j) = gustiness + US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0) + if (do_gustless_tau_mag) & + gustless_mag_tau(i,j) = US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0) if (do_ustar) & ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif @@ -1097,6 +1108,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, endif if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag if (CS%answer_date < 20190101) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else @@ -1110,6 +1122,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag if (CS%answer_date < 20190101) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else @@ -1132,6 +1145,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag if (CS%answer_date < 20190101) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 18bb0dbd06..9c4359bf60 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -55,6 +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 : initialize_ice_shelf_fluxes, initialize_ice_shelf_forces use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart +use MOM_ice_shelf, only : ice_sheet_calving_to_ocean_sfc use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only: Update_Surface_Waves use iso_fortran_env, only : int64 @@ -121,7 +122,10 @@ module ocean_model_mod !! formation in the ocean. melt_potential => NULL(), & !< Instantaneous heat used to melt sea ice [J m-2]. OBLD => NULL(), & !< Ocean boundary layer depth [m]. - area => NULL() !< cell area of the ocean surface [m2]. + area => NULL(), & !< cell area of the ocean surface [m2]. + calving => NULL(), &!< The mass per unit area of the ice shelf to convert to + !! bergs [kg m-2]. + calving_hflx => NULL() !< Calving heat flux [W m-2]. type(coupler_2d_bc_type) :: fields !< A structure that may contain named !! arrays of tracer-related surface fields. integer :: avg_kount !< A count of contributions to running @@ -157,6 +161,8 @@ module ocean_model_mod !! ocean dynamics and forcing fluxes. real :: press_to_z !< A conversion factor between pressure and ocean depth, !! usually 1/(rho_0*g) [Z T2 R-1 L-2 ~> m Pa-1]. + logical :: calve_ice_shelf_bergs = .false. !< If true, bergs are initialized according to + !! ice shelf flux through the ice front real :: C_p !< The heat capacity of seawater [J degC-1 kg-1]. logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode !! with the barotropic and baroclinic dynamics, thermodynamics, @@ -221,7 +227,7 @@ module ocean_model_mod !! This subroutine initializes both the ocean state and the ocean surface type. !! Because of the way that indices and domains are handled, Ocean_sfc must have !! been used in a previous call to initialize_ocean_type. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas_fields_ocn) +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas_fields_ocn, calve_ice_shelf_bergs) type(ocean_public_type), target, & intent(inout) :: Ocean_sfc !< A structure containing various publicly !! visible ocean surface properties after initialization, @@ -239,6 +245,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas !! in the calculation of additional gas or other !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. + logical, optional, intent(in) :: calve_ice_shelf_bergs !< If true, track ice shelf flux through a + !! static ice shelf, so that it can be converted into icebergs ! Local variables real :: Rho0 ! The Boussinesq ocean density [R ~> kg m-3] real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] @@ -247,6 +255,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. logical :: use_melt_pot !< If true, allocate melt_potential array + logical :: point_calving ! Equals calve_ice_shelf_bergs if calve_ice_shelf_bergs is present ! This include declares and sets the variable "version". # include "version_variable.h" @@ -274,11 +283,11 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas OS%Time = Time_in ; OS%Time_dyn = Time_in ! Call initialize MOM with an optional Ice Shelf CS which, if present triggers ! initialization of ice shelf parameters and arrays. - + point_calving=.false.; if (present(calve_ice_shelf_bergs)) point_calving=calve_ice_shelf_bergs call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & Time_in, offline_tracer_mode=OS%offline_tracer_mode, & diag_ptr=OS%diag, count_calls=.true., ice_shelf_CSp=OS%ice_shelf_CSp, & - waves_CSp=OS%Waves) + waves_CSp=OS%Waves, calve_ice_shelf_bergs=point_calving) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) @@ -406,6 +415,13 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas endif + if (present(calve_ice_shelf_bergs)) then + if (calve_ice_shelf_bergs) then + call convert_shelf_state_to_ocean_type(Ocean_sfc, OS%Ice_shelf_CSp, OS%US) + OS%calve_ice_shelf_bergs=.true. + endif + endif + call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) @@ -668,6 +684,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US, & ! OS%fluxes%p_surf_full, OS%press_to_z) call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) + if (OS%calve_ice_shelf_bergs) call convert_shelf_state_to_ocean_type(Ocean_sfc,OS%Ice_shelf_CSp, OS%US) Time1 = OS%Time ; if (do_dyn) Time1 = OS%Time_dyn call coupler_type_send_data(Ocean_sfc%fields, Time1) @@ -789,6 +806,8 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, gas_field Ocean_sfc%u_surf (isc:iec,jsc:jec), & Ocean_sfc%v_surf (isc:iec,jsc:jec), & Ocean_sfc%sea_lev(isc:iec,jsc:jec), & + Ocean_sfc%calving(isc:iec,jsc:jec), & + Ocean_sfc%calving_hflx(isc:iec,jsc:jec), & Ocean_sfc%area (isc:iec,jsc:jec), & Ocean_sfc%melt_potential(isc:iec,jsc:jec), & Ocean_sfc%OBLD (isc:iec,jsc:jec), & @@ -799,6 +818,8 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, gas_field Ocean_sfc%u_surf(:,:) = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models Ocean_sfc%v_surf(:,:) = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models Ocean_sfc%sea_lev(:,:) = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav + Ocean_sfc%calving(:,:) = 0.0 ! time accumulated ice sheet calving (kg m-2) passed to ice model + Ocean_sfc%calving_hflx(:,:) = 0.0 ! time accumulated ice sheet calving heat flux (W m-2) passed to ice model Ocean_sfc%frazil(:,:) = 0.0 ! time accumulated frazil (J/m^2) passed to ice model Ocean_sfc%melt_potential(:,:) = 0.0 ! time accumulated melt potential (J/m^2) passed to ice model Ocean_sfc%OBLD(:,:) = 0.0 ! ocean boundary layer depth (m) @@ -932,6 +953,24 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ end subroutine convert_state_to_ocean_type +!> Converts the ice-shelf-to-ocean calving and calving_hflx variables from the ice-shelf state (ISS) type +!! to the ocean public type +subroutine convert_shelf_state_to_ocean_type(Ocean_sfc, CS, US) + type(ocean_public_type), & + target, intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface fields, whose elements + !! have their data set here. + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd, i, j + + call get_domain_extent(Ocean_sfc%Domain, isc_bnd, iec_bnd, jsc_bnd, jec_bnd) + + call ice_sheet_calving_to_ocean_sfc(CS,US,Ocean_sfc%calving(isc_bnd:iec_bnd,jsc_bnd:jec_bnd),& + Ocean_sfc%calving_hflx(isc_bnd:iec_bnd,jsc_bnd:jec_bnd)) + +end subroutine convert_shelf_state_to_ocean_type + !> This subroutine extracts the surface properties from the ocean's internal !! state and stores them in the ocean type returned to the calling ice model. !! It has to be separate from the ocean_initialization call because the coupler @@ -1026,10 +1065,10 @@ subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly !! visible ocean surface fields. character(len=*) , intent(in) :: name !< The name of the field to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain [various] integer , intent(in) :: isc !< The starting i-index of array2D integer , intent(in) :: jsc !< The starting j-index of array2D + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain [various] integer :: g_isc, g_iec, g_jsc, g_jec, g_isd, g_ied, g_jsd, g_jed, i, j @@ -1149,10 +1188,10 @@ subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly !! visible ocean surface fields. character(len=*) , intent(in) :: name !< The name of the current (ua or va) to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain [L T-1 ~> m s-1] integer , intent(in) :: isc !< The starting i-index of array2D integer , intent(in) :: jsc !< The starting j-index of array2D + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain [L T-1 ~> m s-1] type(ocean_grid_type) , pointer :: G !< The ocean's grid structure type(surface), pointer :: sfc_state !< A structure containing fields that diff --git a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 index 4a4ddf6da3..fb9fbe3e22 100644 --- a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 @@ -20,9 +20,12 @@ function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, character(len=*), intent(in) :: flux_type !< An unused argument character(len=*), intent(in) :: implementation !< An unused argument integer, optional, intent(in) :: atm_tr_index !< An unused argument - real, dimension(:), optional, intent(in) :: param !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument that would be used to + !! pass parameters for flux parameterizations + !! in other contexts [various] logical, dimension(:), optional, intent(in) :: flag !< An unused argument - real, optional, intent(in) :: mol_wt !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument that would usually be + !! the tracer's molecular weight [g mol-1] character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument character(len=*), optional, intent(in) :: units !< An unused argument diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index 787fa7e7d1..753269116a 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -143,7 +143,6 @@ program Shelf_main integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. type(param_file_type) :: param_file ! The structure indicating the file(s) ! containing all run-time parameters. - real :: smb !A constant surface mass balance that can be specified in the param_file character(len=9) :: month character(len=16) :: calendar = 'noleap' integer :: calendar_type=-1 diff --git a/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 index 4a4ddf6da3..fb9fbe3e22 100644 --- a/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 @@ -20,9 +20,12 @@ function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, character(len=*), intent(in) :: flux_type !< An unused argument character(len=*), intent(in) :: implementation !< An unused argument integer, optional, intent(in) :: atm_tr_index !< An unused argument - real, dimension(:), optional, intent(in) :: param !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument that would be used to + !! pass parameters for flux parameterizations + !! in other contexts [various] logical, dimension(:), optional, intent(in) :: flag !< An unused argument - real, optional, intent(in) :: mol_wt !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument that would usually be + !! the tracer's molecular weight [g mol-1] character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument character(len=*), optional, intent(in) :: units !< An unused argument diff --git a/config_src/drivers/timing_tests/time_MOM_remapping.F90 b/config_src/drivers/timing_tests/time_MOM_remapping.F90 new file mode 100644 index 0000000000..e4bea9d94f --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_remapping.F90 @@ -0,0 +1,103 @@ +program time_MOM_remapping + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_remapping, only : remapping_CS +use MOM_remapping, only : initialize_remapping +use MOM_remapping, only : remapping_core_h + +implicit none + +type(remapping_CS) :: CS +integer, parameter :: nk=75, nij=20*20, nits=10, nsamp=100, nschemes = 2 +character(len=10) :: scheme_labels(nschemes) +real, dimension(nschemes) :: timings ! Time for nits of nij calls for each scheme [s] +real, dimension(nschemes) :: tmean ! Mean time for a call [s] +real, dimension(nschemes) :: tstd ! Standard deviation of time for a call [s] +real, dimension(nschemes) :: tmin ! Shortest time for a call [s] +real, dimension(nschemes) :: tmax ! Longest time for a call [s] +real, dimension(:,:), allocatable :: u0, u1 ! Source/target values [arbitrary but same units as each other] +real, dimension(:,:), allocatable :: h0, h1 ! Source target thicknesses [0..1] [nondim] +real :: start, finish ! Times [s] +real :: h_neglect ! A negligible thickness [nondim] +real :: h0sum, h1sum ! Totals of h0 and h1 [nondim] +integer :: ij, k, isamp, iter, ischeme ! Indices and counters +integer :: seed_size ! Number of integers used by seed +integer, allocatable :: seed(:) ! Random number seed + +! Set seed for random numbers +call random_seed(size=seed_size) +allocate( seed(seed_Size) ) +seed(:) = 102030405 +call random_seed(put=seed) + +scheme_labels(1) = 'PCM' +scheme_labels(2) = 'PLM' + +! Set up some test data (note: using k,i indexing rather than i,k) +allocate( u0(nk,nij), h0(nk,nij), u1(nk,nij), h1(nk,nij) ) +call random_number(u0) ! In range 0-1 +call random_number(h0) ! In range 0-1 +call random_number(h1) ! In range 0-1 +do ij = 1, nij + h0(:,ij) = max(0., h0(:,ij) - 0.05) ! Make 5% of values equal to zero + h1(:,ij) = max(0., h1(:,ij) - 0.05) ! Make 5% of values equal to zero + h0sum = h0(1,ij) + h1sum = h1(1,ij) + do k = 2, nk + h0sum = h0sum + h0(k,ij) + h1sum = h1sum + h1(k,ij) + enddo + h0(:,ij) = h0(:,ij) / h0sum + h1(:,ij) = h1(:,ij) / h1sum +enddo +h_neglect = 1.0-30 + +! Loop over many samples of timing loop to collect statistics +tmean(:) = 0. +tstd(:) = 0. +tmin(:) = 1.e9 +tmax(:) = 0. +do isamp = 1, nsamp + ! Time reconstruction + remapping + do ischeme = 1, nschemes + call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme)), & + h_neglect=h_neglect, h_neglect_edge=h_neglect) + call cpu_time(start) + do iter = 1, nits ! Make many passes to reduce sampling error + do ij = 1, nij ! Calling nij times to make similar to cost in MOM_ALE() + call remapping_core_h(CS, nk, h0(:,ij), u0(:,ij), nk, h1(:,ij), u1(:,ij)) + enddo + enddo + call cpu_time(finish) + timings(ischeme) = (finish-start)/real(nits*nij) ! Average time per call + enddo + tmean(:) = tmean(:) + timings(:) + tstd(:) = tstd(:) + timings(:)**2 ! tstd contains sum of squares here + tmin(:) = min( tmin(:), timings(:) ) + tmax(:) = max( tmax(:), timings(:) ) +enddo +tmean(:) = tmean(:) / real(nsamp) ! convert to mean +tstd(:) = tstd(:) / real(nsamp) ! convert to mean of squares +tstd(:) = tstd(:) - tmean(:)**2 ! convert to variance +tstd(:) = sqrt( tstd(:) * real(nsamp) / real(nsamp-1) ) ! convert to standard deviation + + +! Display results in YAML +write(*,'(a)') "{" +do ischeme = 1, nschemes + write(*,"(2x,5a)") '"MOM_remapping remapping_core_h(remapping_scheme=', & + trim(scheme_labels(ischeme)), ')": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ',tmin(ischeme) + write(*,"(4x,a,1pe11.4,',')") '"mean":',tmean(ischeme) + write(*,"(4x,a,1pe11.4,',')") '"std": ',tstd(ischeme) + write(*,"(4x,a,i7,',')") '"n_samples": ',nsamp + if (ischeme.ne.nschemes) then + write(*,"(4x,a,1pe11.4,'},')") '"max": ',tmax(ischeme) + else + write(*,"(4x,a,1pe11.4,'}')") '"max": ',tmax(ischeme) + endif +enddo +write(*,'(a)') "}" + +end program time_MOM_remapping diff --git a/config_src/drivers/unit_tests/test_MOM_remapping.F90 b/config_src/drivers/unit_tests/test_MOM_remapping.F90 new file mode 100644 index 0000000000..e62b779bd6 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_remapping.F90 @@ -0,0 +1,7 @@ +program test_MOM_remapping + +use MOM_remapping, only : remapping_unit_tests + +if (remapping_unit_tests(.true.)) stop 1 + +end program test_MOM_remapping diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 index fec9c80461..5c87c37e70 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -99,8 +99,9 @@ module g_tracer_utils contains !> Unknown - subroutine g_tracer_flux_init(g_tracer) + subroutine g_tracer_flux_init(g_tracer, verbosity) type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity end subroutine g_tracer_flux_init !> Unknown diff --git a/config_src/external/drifters/MOM_particles_types.F90 b/config_src/external/drifters/MOM_particles_types.F90 index 51e744a186..30fecad7a2 100644 --- a/config_src/external/drifters/MOM_particles_types.F90 +++ b/config_src/external/drifters/MOM_particles_types.F90 @@ -3,6 +3,7 @@ module particles_types_mod ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : int64 use MOM_grid, only : ocean_grid_type use MOM_domains, only: domain2D @@ -75,7 +76,7 @@ module particles_types_mod real :: vvel_old !< Previous meridional velocity component (m/s) integer :: year !< Year of this record integer :: particle_num !< Current particle number - integer(kind=8) :: id = -1 !< Particle Identifier + integer(kind=int64) :: id = -1 !< Particle Identifier type(xyt), pointer :: next=>null() !< Pointer to the next position in the list end type xyt @@ -98,8 +99,8 @@ module particles_types_mod real :: start_day !< origination position (degrees) and day integer :: start_year !< origination year real :: halo_part !< equal to zero for particles on the computational domain, and 1 for particles on the halo - integer(kind=8) :: id !< particle identifier - integer(kind=8) :: drifter_num !< particle identifier + integer(kind=int64) :: id !< particle identifier + integer(kind=int64) :: drifter_num !< particle identifier integer :: ine !< nearest i-index in NE direction (for convenience) integer :: jne !< nearest j-index in NE direction (for convenience) real :: xi !< non-dimensional x-coordinate within current cell (0..1) @@ -147,7 +148,7 @@ module particles_types_mod logical :: ignore_traj=.False. !< If true, then model does not write trajectory data at all logical :: use_new_predictive_corrective =.False. !< Flag to use Bob's predictive corrective particle scheme !Added by Alon - integer(kind=8) :: debug_particle_with_id = -1 !< If positive, monitors a part with this id + integer(kind=int64) :: debug_particle_with_id = -1 !< If positive, monitors a part with this id type(buffer), pointer :: obuffer_n=>null() !< Buffer for outgoing parts to the north type(buffer), pointer :: ibuffer_n=>null() !< Buffer for incoming parts from the north type(buffer), pointer :: obuffer_s=>null() !< Buffer for outgoing parts to the south diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index 232986f480..d9be18d33f 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -8,6 +8,7 @@ module MOM_diag_manager_infra ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : real64 use diag_axis_mod, only : fms_axis_init=>diag_axis_init use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name use diag_axis_mod, only : EAST, NORTH @@ -359,7 +360,7 @@ end function send_data_infra_3d logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + real(kind=real64), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded @@ -382,7 +383,7 @@ end function send_data_infra_2d_r8 logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + real(kind=real64), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 index f05baa4474..57f92c2046 100644 --- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -8,6 +8,7 @@ module MOM_diag_manager_infra ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : real64 use diag_axis_mod, only : fms_axis_init=>diag_axis_init use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name use diag_axis_mod, only : EAST, NORTH @@ -361,7 +362,7 @@ end function send_data_infra_3d logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + real(kind=real64), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded @@ -384,7 +385,7 @@ end function send_data_infra_2d_r8 logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + real(kind=real64), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded diff --git a/docs/forcing.rst b/docs/forcing.rst index 8496317608..21539d46d0 100644 --- a/docs/forcing.rst +++ b/docs/forcing.rst @@ -1,23 +1,23 @@ Forcing ======= Data Override -------- +------------- When running MOM6 with the Flexible Modelling System (FMS) coupler, forcing can be specified by a `data_table` file. This is particularly useful when running MOM6 with a data atmosphere, as paths to the relevent atmospheric forcing products (eg. JRA55-do or ERA5) can be provided here. Each item in the data table must be separated by a new line, and contains the following information: | ``gridname``: The component of the model this data applies to. eg. `atm` `ocn` `lnd` `ice`. | ``fieldname_code``: The field name according to the model component. eg. `salt` -| ``fieldname_file``: The name of the field within the source file. +| ``fieldname_file``: The name of the field within the source file. | ``file_name``: Path to the source file. | ``interpol_method``: Interpolation method eg. `bilinear` -| ``factor``: A scalar by which to multiply the field ahead of passing it onto the model. This is a quick way to do unit conversions for example. +| ``factor``: A scalar by which to multiply the field ahead of passing it onto the model. This is a quick way to do unit conversions for example. +| -| The data table is commonly formatted by specifying each of the fields in the order listed above, with a new line for each entry. Example Format: "ATM", "t_bot", "t2m", "./INPUT/2t_ERA5.nc", "bilinear", 1.0 -A `yaml` format is also possible if you prefer. This is outlined in the `FMS data override `_ github page, along with other details. +A `yaml` format is also possible if you prefer. This is outlined in the `FMS data override `_ github page, along with other details. Speficying a constant value: Rather than overriding with data from a file, one can also set a field to constant. To do this, pass empty strings to `fieldname_file` and `file_name`. The `factor` now corresponds to the override value. For example, the following sets the temperature at the bottom of the atmosphere to 290 Kelvin. @@ -26,7 +26,7 @@ Speficying a constant value: "ATM", "t_bot", "", "", "bilinear", 290.0 Which units do I need? - For configurations using SIS2 and MOM, a list of available surface flux variables along with the expected units can be found in the `flux_exchange `_ file. + For configurations using SIS2 and MOM, a list of available surface flux variables along with the expected units can be found in the `flux_exchange `_ file. .. toctree:: diff --git a/docs/ocean.bib b/docs/ocean.bib index ec35116efc..33107fbae1 100644 --- a/docs/ocean.bib +++ b/docs/ocean.bib @@ -10,18 +10,6 @@ @article{Adcroft2004 journal = {Ocean Modelling} } -@article{Adcroft2019, - doi = {10.1029/2019ms001726}, - year = 2019, - publisher = {American Geophysical Union ({AGU})}, - volume = {11}, - number = {10}, - pages = {3167--3211}, - author = {A. Adcroft and W. Anderson and V. Balaji and C. Blanton and M. Bushuk and C. O. Dufour and J. P. Dunne and S. M. Griffies and R. Hallberg and M. J. Harrison and I. M. Held and M. F. Jansen and J. G. John and J. P. Krasting and A. R. Langenhorst and S. Legg and Z. Liang and C. McHugh and A. Radhakrishnan and B. G. Reichl and T. Rosati and B. L. Samuels and A. Shao and R. Stouffer and M. Winton and A. T. Wittenberg and B. Xiang and N. Zadeh and R. Zhang}, - title = {The {GFDL} Global Ocean and Sea Ice Model {OM}4.0: Model Description and Simulation Features}, - journal = {J. Adv. Mod. Earth Sys.} -} - @article{Campin2004, doi = {10.1016/s1463-5003(03)00009-x}, year = 2004, diff --git a/docs/parameterizations_lateral.rst b/docs/parameterizations_lateral.rst index 3a3266a2bb..d175c7e8bb 100644 --- a/docs/parameterizations_lateral.rst +++ b/docs/parameterizations_lateral.rst @@ -8,6 +8,8 @@ Lateral viscosity Laplacian and bi-harmonic viscosities with linear and Smagorinsky options are implemented in MOM_hor_visc. + :ref:`namespacemom__hor__visc_1section_horizontal_viscosity` + Gent-McWilliams/TEM/isopycnal height diffusion ---------------------------------------------- @@ -20,7 +22,7 @@ scaling. A model of sub-grid scale Mesoscale Eddy Kinetic Energy (MEKE) is implement in MOM_MEKE and the associated diffusivity added in MOM_thickness_diffuse. See :cite:`jansen2015` and :cite:`marshall2010`. - :ref:`namespacemom__meke_1section_MEKE` + :ref:`namespacemom__meke_1section_MEKE` Backscatter ----------- @@ -32,17 +34,43 @@ Mixed layer restratification by sub-mesoscale eddies ---------------------------------------------------- Mixed layer restratification from :cite:`fox-kemper2008` and -:cite:`fox-kemper2008-2` is implemented in MOM_mixed_layer_restrat. +:cite:`fox-kemper2008-2` is implemented in MOM_mixed_layer_restrat, +which now also contains the mixed layer restratication comes from :cite: Bodner2023. + + :ref:`namespacemom__mixed__layer__restrat_1section_mle` + +Interface filtering +------------------- + +For layer mode, one can filter the interface thicknesses: + + :ref:`namespacemom__interface__filter_1section_interface_filter` Lateral diffusion ----------------- See :ref:`Horizontal_Diffusion`. +See also :ref:`namespacemom__lateral__mixing__coeffs_1section_Resolution_Function` + Tidal forcing ------------- -Astronomical tidal forcings and self-attraction and loading are implement in MOM_tidal_forcing. -Tides can also be added via an open boundary tidal specification, -see [OBC wiki page](https://github.com/NOAA-GFDL/MOM6-examples/wiki/Open-Boundary-Conditions). +Astronomical tidal forcings and self-attraction and loading are implement in + + :ref:`namespacetidal__forcing_1section_tides` +The Love numbers are stored internally in MOM_load_love_numbers: + + :ref:`namespacemom__load__love__numbers_1section_Love_numbers` + +while the self attraction and loading is computed in MOM_self_attr_load: + + :ref:`namespaceself__attr__load_1section_SAL` + +The self attraction and loading needs spherical harmonics, computed in MOM_spherical_harmonics: + + :ref:`namespacemom__spherical__harmonics_1section_spherical_harmonics` + +Tides can also be added via an open boundary tidal specification, +see `OBC wiki page `_. diff --git a/docs/zotero.bib b/docs/zotero.bib index c0f1ddccbb..bbd2e30478 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -967,7 +967,7 @@ @article{bitz1999 pages = {15669--15677} } -@inproceedings{briegleb2007, +@incollection{briegleb2007, series = {Technical {Note}}, title = {A {Delta}-{Eddington} {Mutiple} {Scattering} {Parameterization} for {Solar} {Radiation} in the {Sea} {Ice} {Component} of the {Community} {Climate} {System} {Model} {\textbar} {OpenSky} {Repository}}, url = {http://opensky.ucar.edu/islandora/object/technotes:484}, @@ -2447,7 +2447,7 @@ @article{russell1981 doi = {10.1175/1520-0450(1981)020<1483:ANFDSF>2.0.CO;2} } -@inproceedings{huynh1997, +@incollection{huynh1997, title = {Schemes and constraints for advection}, booktitle = {Fifteenth International Conference on Numerical Methods in Fluid Dynamics}, @@ -2524,7 +2524,7 @@ @article{visbeck1997 } @article{visbeck1996, - author = {Viscbeck, M. and J.C. Marshall and H. Jones}, + author = {Visbeck, M. and J.C. Marshall and H. Jones}, year = {1996}, title = {Dynamics of isolated convective regions in the ocean}, journal = {J. Phys. Oceanogr.}, @@ -2564,7 +2564,7 @@ @article{marshall2010 doi = {10.1016/j.ocemod.2010.02.001} } -@inproceedings{millero1978, +@incollection{millero1978, author = {Millero, F.J.}, title = {Freezing point of seawater}, note = {Annex 6}, @@ -2760,3 +2760,189 @@ @article{Adcroft2019 journal = {J. Adv. Mod. Earth Sys.} } +@article{Bodner2023, + title={Modifying the Mixed Layer Eddy Parameterization to Include Frontogenesis Arrest by Boundary Layer Turbulence}, + volume={53}, + ISSN={1520-0485}, + url={http://dx.doi.org/10.1175/JPO-D-21-0297.1}, + DOI={10.1175/jpo-d-21-0297.1}, + number={1}, + journal={Journal of Physical Oceanography}, + publisher={American Meteorological Society}, + author={Bodner, Abigail S. and Fox-Kemper, Baylor and Johnson, Leah and Van Roekel, Luke P. and McWilliams, James C. and Sullivan, Peter P. and Hall, Paul S. and Dong, Jihai}, + year={2023}, + month=jan, + pages={323-–339} +} + +@article{Oberhuber1993a, + title={Simulation of the Atlantic Circulation with a Coupled Sea Ice-Mixed Layer-Isopycnal General Circulation Model. Part I: Model Description}, + volume={23}, + ISSN={1520-0485}, + url={http://dx.doi.org/10.1175/1520-0485(1993)023<0808:SOTACW>2.0.CO;2}, + DOI={10.1175/1520-0485(1993)023<0808:sotacw>2.0.co;2}, + number={5}, + journal={Journal of Physical Oceanography}, + publisher={American Meteorological Society}, + author={Oberhuber, Josef M.}, + year={1993}, + month=may, + pages={808–829} +} + +@article{Smith2003, + title={Anisotropic horizontal viscosity for ocean models}, + volume={5}, + ISSN={1463-5003}, + url={http://dx.doi.org/10.1016/s1463-5003(02)00016-1}, + DOI={10.1016/s1463-5003(02)00016-1}, + number={2}, + journal={Ocean Modelling}, + publisher={Elsevier BV}, + author={Smith, Richard D. and McWilliams, James C.}, + year={2003}, + month=jan, + pages={129–156} +} + +@article{Large2001, + title={Equatorial Circulation of a Global Ocean Climate Model with Anisotropic Horizontal Viscosity}, + volume={31}, + ISSN={1520-0485}, + url={http://dx.doi.org/10.1175/1520-0485(2001)031<0518:ECOAGO>2.0.CO;2}, + DOI={10.1175/1520-0485(2001)031<0518:ecoago>2.0.co;2}, + number={2}, + journal={Journal of Physical Oceanography}, + publisher={American Meteorological Society}, + author={Large, William G. and Danabasoglu, Gokhan and McWilliams, James C. and Gent, Peter R. and Bryan, Frank O.}, + year={2001}, + month=feb, + pages={518–536} +} + +@incollection{Smagorinsky1993, + author={Joseph Smagorinsky}, + year={1993}, + title={Some historical remarks on the use of non-linear viscosities}, + booktitle={Large Eddy Simulation of Complex Engineering and Geophysical Flows}, + note={Proceedings of an International Workshop in Large Eddy Simulation}, + address={Cambridge, UK}, + publisher={Cambridge University Press}, + pages={1--34} +} + +@article{Barton2022, + title={Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in MPAS‐Ocean}, + volume={14}, + ISSN={1942-2466}, + url={http://dx.doi.org/10.1029/2022MS003207}, + DOI={10.1029/2022ms003207}, + number={11}, + journal={Journal of Advances in Modeling Earth Systems}, + publisher={American Geophysical Union (AGU)}, + author={Barton, Kristin N. and Pal, Nairita and Brus, Steven R. and Petersen, Mark R. and Arbic, Brian K. and Engwirda, Darren and Roberts, Andrew F. and Westerink, Joannes J. and Wirasaet, Damrongsak and Schindelegger, Michael}, + year={2022}, + month=nov +} + +@article{Brus2023, + title={Scalable self attraction and loading calculations for unstructured ocean tide models}, + volume={182}, + ISSN={1463-5003}, + url={http://dx.doi.org/10.1016/j.ocemod.2023.102160}, + DOI={10.1016/j.ocemod.2023.102160}, + journal={Ocean Modelling}, + publisher={Elsevier BV}, + author={Brus, Steven R. and Barton, Kristin N. and Pal, Nairita and Roberts, Andrew F. and Engwirda, Darren and Petersen, Mark R. and Arbic, Brian K. and Wirasaet, Damrongsak and Westerink, Joannes J. and Schindelegger, Michael}, + year={2023}, + month=apr, + pages={102160} +} + +@article{Blewitt2003, + title={Self‐consistency in reference frames, geocenter definition, and surface loading of the solid Earth}, + volume={108}, + ISSN={0148-0227}, + url={http://dx.doi.org/10.1029/2002JB002082}, + DOI={10.1029/2002jb002082}, + number={B2}, + journal={Journal of Geophysical Research: Solid Earth}, + publisher={American Geophysical Union (AGU)}, + author={Blewitt, Geoffrey}, + year={2003}, + month=feb +} + +@article{Wang2012-2, + author={Wang, H. and Xiang, L. and Jia, L. and Jiang, L. and Wang, Z. and Hu, B. + and Gao, P.}, + year={2012}, + title={Load Love numbers and Green's functions +for elastic Earth models PREM, iasp91, ak135, and modified models with refined crustal structure from Crust 2.0}, + journal={Computers & Geosciences}, + volume={49}, + pages={190--199} +} + +@incollection{Hallberg2003, + title={The ability of large-scale ocean models to accept parameterizations of boundary mixing, and a description of a refined bulk mixed-layer model}, + author={Robert Hallberg}, + year={2003}, + booktitle={Internal Gravity Waves and Small-Scale Turbulence: Proc.‘Aha Huliko ‘a Hawaiian Winter Workshop}, + pages={187--203} +} + +@article{Accad1978, + volume={290}, + ISSN={2054-0272}, + url={http://dx.doi.org/10.1098/rsta.1978.0083}, + DOI={10.1098/rsta.1978.0083}, + number={1368}, + journal={Philosophical Transactions of the Royal Society of London. Series A, Mathematical and Physical Sciences}, + publisher={The Royal Society}, + year={1978}, + month=nov, + pages={235-–266}, + author={Accad, Y. and Pekeris, C.L.}, + title={Solution of the tidal equations for the M2 and S2 tides in the world oceans from a + knowledge of the tidal potential alone} +} + +@article{Arbic2004, + title={The accuracy of surface elevations in forward global barotropic and baroclinic tide models}, + volume={51}, + ISSN={0967-0645}, + url={http://dx.doi.org/10.1016/j.dsr2.2004.09.014}, + DOI={10.1016/j.dsr2.2004.09.014}, + number={25–26}, + journal={Deep Sea Research Part II: Topical Studies in Oceanography}, + publisher={Elsevier BV}, + author={Arbic, Brian K. and Garner, Stephen T. and Hallberg, Robert W. and Simmons, Harper L.}, + year={2004}, + month=dec, + pages={3069-–3101} +} + +@article{Schaeffer2013, + title={Efficient spherical harmonic transforms aimed at pseudospectral numerical simulations}, + volume={14}, + ISSN={1525-2027}, + url={http://dx.doi.org/10.1002/ggge.20071}, + DOI={10.1002/ggge.20071}, + number={3}, + journal={Geochemistry, Geophysics, Geosystems}, + publisher={American Geophysical Union (AGU)}, + author={Schaeffer, Nathanaël}, + year={2013}, + month=mar, + pages={751-–758} +} + +@article{Young1994, + author={Young, W.}, + title={The subinertial mixed layer approximation}, + journal={J. Phys. Oceanogr.}, + volume={24}, + pages={1812--1826}, + year={1994} +} diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index a083402fde..bc3099d68d 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -178,8 +178,10 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) logical :: local_logical logical :: remap_boundary_extrap logical :: init_boundary_extrap + logical :: om4_remap_via_sub_cells type(hybgen_regrid_CS), pointer :: hybgen_regridCS => NULL() ! Control structure for hybgen regridding ! for sharing parameters. + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (associated(CS)) then call MOM_error(WARNING, "ALE_init called with an associated "// & @@ -234,6 +236,11 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) + call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "This selects the remapping algorithm used in OM4 that does not use "//& + "the full reconstruction for the top- and lower-most sub-layers, but instead "//& + "assumes they are always vanished (untrue) and so just uses their edge values. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& @@ -242,18 +249,30 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + if (CS%answer_date >= 20190101) 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 + endif + call initialize_remapping( CS%remapCS, string, & boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & - answer_date=CS%answer_date) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) call initialize_remapping( CS%vel_remapCS, vel_string, & boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & - answer_date=CS%answer_date) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) call get_param(param_file, mdl, "PARTIAL_CELL_VELOCITY_REMAP", CS%partial_cell_vel_remap, & "If true, use partial cell thicknesses at velocity points that are masked out "//& @@ -326,6 +345,21 @@ subroutine ALE_set_extrap_boundaries( param_file, CS) call remapping_set_param(CS%remapCS, boundary_extrapolation=remap_boundary_extrap) end subroutine ALE_set_extrap_boundaries +!> Sets the remapping algorithm to that of OM4 +!! +!! The remapping aglorithm used in OM4 made poor assumptions about the reconstructions +!! in the top/bottom layers, namely that they were always vanished and could be +!! represented solely by their upper/lower edge value respectively. +!! Passing .false. here uses the full reconstruction of those top and bottom layers +!! and properly sample those layers. +subroutine ALE_set_OM4_remap_algorithm( CS, om4_remap_via_sub_cells ) + type(ALE_CS), pointer :: CS !< Module control structure + logical, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm + + call remapping_set_param(CS%remapCS, om4_remap_via_sub_cells=om4_remap_via_sub_cells ) + +end subroutine ALE_set_OM4_remap_algorithm + !> Initialize diagnostics for the ALE module. subroutine ALE_register_diags(Time, G, GV, US, diag, CS) type(time_type),target, intent(in) :: Time !< Time structure @@ -568,8 +602,8 @@ subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, endif enddo ; enddo - call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T, answer_date=CS%answer_date) - call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S, answer_date=CS%answer_date) + call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T) + call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S) if (debug) call MOM_tracer_chkinv("After ALE_offline_inputs", G, GV, h_new, Reg%Tr, Reg%ntr) @@ -630,7 +664,6 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface ! Interface height changes within ! an iteration [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzIntTotal ! Cumulative interface position changes [H ~> m or kg m-2] - real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] nz = GV%ke @@ -657,14 +690,6 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d if (present(dt)) & call ALE_update_regrid_weights(dt, CS) - if (CS%answer_date >= 20190101) 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 - endif - do itt = 1, n_itt call do_group_pass(pass_T_S_h, G%domain) @@ -681,10 +706,8 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d ! remap from original grid onto new grid do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), tv_local%S(i,j,:), & - h_neglect, h_neglect_edge) - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:), & - h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), tv_local%S(i,j,:)) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:)) enddo ; enddo ! starting grid for next iteration @@ -740,7 +763,6 @@ subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: h1(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] - real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] logical :: show_call_tree type(tracer_type), pointer :: Tr => NULL() integer :: i, j, k, m, nz, ntr @@ -748,14 +770,6 @@ subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) show_call_tree = .false. if (present(debug)) show_call_tree = debug - if (CS%answer_date >= 20190101) 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 - endif - if (show_call_tree) call callTree_enter("ALE_remap_tracers(), MOM_ALE.F90") nz = GV%ke @@ -780,11 +794,9 @@ subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) h2(:) = h_new(i,j,:) if (present(PCM_cell)) then PCM(:) = PCM_cell(i,j,:) - call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, & - h_neglect, h_neglect_edge, PCM_cell=PCM) + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, PCM_cell=PCM) else - call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, & - h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column) endif ! Possibly underflow any very tiny tracer concentrations to 0. Note that this is not conservative! @@ -1068,7 +1080,6 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u real :: v_tgt(GV%ke) ! A column of v-velocities on the target grid [L T-1 ~> m s-1] real :: h1(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] - real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] logical :: show_call_tree integer :: i, j, k, nz @@ -1076,14 +1087,6 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u if (present(debug)) show_call_tree = debug if (show_call_tree) call callTree_enter("ALE_remap_velocities()") - if (CS%answer_date >= 20190101) 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 - endif - nz = GV%ke ! --- Remap u profiles from the source vertical grid onto the new target grid. @@ -1097,8 +1100,7 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u u_src(k) = u(I,j,k) enddo - call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt, & - h_neglect, h_neglect_edge) + call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt) if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) & call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) @@ -1123,8 +1125,7 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u v_src(k) = v(i,J,k) enddo - call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt, & - h_neglect, h_neglect_edge) + call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt) if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then call mask_near_bottom_vel(v_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) @@ -1277,8 +1278,7 @@ end subroutine mask_near_bottom_vel !> Remaps a single scalar between grids described by thicknesses h_src and h_dst. !! h_dst must be dimensioned as a model array with GV%ke layers while h_src can !! have an arbitrary number of layers specified by nk_src. -subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_cells, old_remap, & - answers_2018, answer_date, h_neglect, h_neglect_edge) +subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_cells, old_remap) type(remapping_CS), intent(in) :: CS !< Remapping control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -1296,44 +1296,16 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c !! layers otherwise (default). logical, optional, intent(in) :: old_remap !< If true, use the old "remapping_core_w" !! method, otherwise use "remapping_core_h". - logical, optional, intent(in) :: answers_2018 !< If true, use the order of arithmetic - !! and expressions that recover the answers for - !! remapping from the end of 2018. Otherwise, - !! use more robust forms of the same expressions. - integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use - !! for remapping - real, optional, intent(in) :: h_neglect !< A negligibly small thickness used in - !! remapping cell reconstructions, in the same - !! units as h_src, often [H ~> m or kg m-2] - real, optional, intent(in) :: h_neglect_edge !< A negligibly small thickness used in - !! remapping edge value calculations, in the same - !! units as h_src, often [H ~> m or kg m-2] - ! Local variables + ! Local variables integer :: i, j, k, n_points real :: dx(GV%ke+1) ! Change in interface position [H ~> m or kg m-2] - real :: h_neg, h_neg_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] - logical :: ignore_vanished_layers, use_remapping_core_w, use_2018_remap + logical :: ignore_vanished_layers, use_remapping_core_w ignore_vanished_layers = .false. if (present(all_cells)) ignore_vanished_layers = .not. all_cells use_remapping_core_w = .false. if (present(old_remap)) use_remapping_core_w = old_remap n_points = nk_src - use_2018_remap = .true. ; if (present(answers_2018)) use_2018_remap = answers_2018 - if (present(answer_date)) use_2018_remap = (answer_date < 20190101) - - if (present(h_neglect)) then - h_neg = h_neglect - h_neg_edge = h_neg ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge - else - if (.not.use_2018_remap) then - h_neg = GV%H_subroundoff ; h_neg_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neg = GV%m_to_H*1.0e-30 ; h_neg_edge = GV%m_to_H*1.0e-10 - else - h_neg = GV%kg_m2_to_H*1.0e-30 ; h_neg_edge = GV%kg_m2_to_H*1.0e-10 - endif - endif !$OMP parallel do default(shared) firstprivate(n_points,dx) do j = G%jsc,G%jec ; do i = G%isc,G%iec @@ -1348,10 +1320,10 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c if (use_remapping_core_w) then call dzFromH1H2( n_points, h_src(i,j,1:n_points), GV%ke, h_dst(i,j,:), dx ) call remapping_core_w(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & - GV%ke, dx, s_dst(i,j,:), h_neg, h_neg_edge) + GV%ke, dx, s_dst(i,j,:)) else call remapping_core_h(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & - GV%ke, h_dst(i,j,:), s_dst(i,j,:), h_neg, h_neg_edge) + GV%ke, h_dst(i,j,:), s_dst(i,j,:)) endif else s_dst(i,j,:) = 0. diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 index 491693549f..8c0733be78 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -258,9 +258,9 @@ subroutine write_Hybgen_coord_file(GV, CS, filepath) call create_MOM_file(IO_handle, trim(filepath), vars, 3, fields, & SINGLE_FILE, GV=GV) - call MOM_write_field(IO_handle, fields(1), CS%dp0k, scale=CS%coord_scale) - call MOM_write_field(IO_handle, fields(2), CS%ds0k, scale=CS%coord_scale) - call MOM_write_field(IO_handle, fields(3), CS%target_density, scale=CS%Rho_coord_scale) + call MOM_write_field(IO_handle, fields(1), CS%dp0k, unscale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(2), CS%ds0k, unscale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(3), CS%target_density, unscale=CS%Rho_coord_scale) call IO_handle%close() end subroutine write_Hybgen_coord_file diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 8faec6c495..0d325292f5 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -211,6 +211,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m real :: tmpReal ! A temporary variable used in setting other variables [various] real :: P_Ref ! The coordinate variable reference pression [R L2 T-2 ~> Pa] real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). + real :: dz_extra ! The thickness of an added layer to append to the woa09_dz profile when + ! maximum_depth is large [m] (not in Z). real :: adaptTimeRatio, adaptZoomCoeff ! Temporary variables for input parameters [nondim] real :: adaptBuoyCoeff, adaptAlpha ! Temporary variables for input parameters [nondim] real :: adaptZoom ! The thickness of the near-surface zooming region with the adaptive coordinate [H ~> m or kg m-2] @@ -224,12 +226,38 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m real, dimension(:), allocatable :: dz_max ! Thicknesses used to find maximum interface depths ! [H ~> m or kg m-2] or other units real, dimension(:), allocatable :: rho_target ! Target density used in HYBRID mode [kg m-3] - !> Thicknesses [m] that give level centers corresponding to table 2 of WOA09 - real, dimension(40) :: woa09_dz = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & - 37.5, 50., 50., 75., 100., 100., 100., 100., & - 100., 100., 100., 100., 100., 100., 100., 175., & - 250., 375., 500., 500., 500., 500., 500., 500., & - 500., 500., 500., 500., 500., 500., 500., 500. /) + ! Thicknesses [m] that give level centers approximately corresponding to table 2 of WOA09 + ! These are approximate because the WOA09 depths are not smoothly spaced. Levels + ! 1, 4, 5, 9, 12, 24, and 36 are 2.5, 2.5, 1.25 12.5, 37.5 and 62.5 m deeper than WOA09 + ! but all others are identical. + real, dimension(40) :: woa09_dz_approx = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & + 37.5, 50., 50., 75., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 175., & + 250., 375., 500., 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., 500., 500., 500. /) + ! These are the actual spacings [m] between WOA09 depths which, if used for layer thickness, places + ! the interfaces at the WOA09 depths. + real, dimension(39) :: woa09_dzi = (/ 10., 10., 10., 20., 25., 25., 25., 25., & + 50., 50., 50., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 250., & + 250., 500., 500., 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., 500., 500. /) + ! These are the spacings [m] between WOA23 depths from table 3 of + ! https://www.ncei.noaa.gov/data/oceans/woa/WOA13/DOC/woa13documentation.pdf + real, dimension(136) :: woa23_dzi = (/ 5., 5., 5., 5., 5., 5., 5., 5., 5., 5., & + 5., 5., 5., 5., 5., 5., 5., 5., 5., 5., & + 25., 25., 25., 25., 25., 25., 25., 25., 25., 25., & + 25., 25., 25., 25., 25., 25., 50., 50., 50., 50., & + 50., 50., 50., 50., 50., 50., 50., 50., 50., 50., & + 50., 50., 50., 50., 50., 50., 50., 50., 50., 50., & + 50., 50., 50., 50., 50., 50., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100. /) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) @@ -311,7 +339,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m param_name = create_coord_param(param_prefix, "DEF", param_suffix) coord_res_param = create_coord_param(param_prefix, "RES", param_suffix) string2 = 'UNIFORM' - if (maximum_depth>3000.) string2='WOA09' ! For convenience + if ((maximum_depth>3000.) .and. (maximum_depth<9250.)) string2='WOA09' ! For convenience endif call get_param(param_file, mdl, param_name, string, & "Determines how to specify the coordinate "//& @@ -323,6 +351,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m " by a comma or space, e.g. FILE:lev.nc,dz\n"//& " or FILE:lev.nc,interfaces=zw\n"//& " WOA09[:N] - the WOA09 vertical grid (approximately)\n"//& + " WOA09INT[:N] - layers spanned by the WOA09 depths\n"//& + " WOA23INT[:N] - layers spanned by the WOA23 depths\n"//& " FNC1:string - FNC1:dz_min,H_total,power,precision\n"//& " HYBRID:string - read from a file. The string specifies\n"//& " the filename and two variable names, separated\n"//& @@ -456,22 +486,75 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target, & 'HYBRID target densities for interfaces', units=coordinateUnits(coord_mode)) endif + elseif (index(trim(string),'WOA09INT')==1) then + if (len_trim(string)==8) then ! string=='WOA09INT' + tmpReal = 0. ; ke = 0 ; dz_extra = 0. + do while (tmpReal size(woa09_dzi)) then + dz_extra = maximum_depth - tmpReal + exit + endif + tmpReal = tmpReal + woa09_dzi(ke) + enddo + elseif (index(trim(string),'WOA09INT:')==1) then ! string starts with 'WOA09INT:' + if (len_trim(string)==9) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'Expected string of form "WOA09INT:N" but got "'//trim(string)//'".') + ke = extract_integer(string(10:len_trim(string)),'',1) + if (ke>39 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05INT:N" N must 0 size(woa09_dzi)) dz(ke) = dz_extra + elseif (index(trim(string),'WOA23INT')==1) then + if (len_trim(string)==8) then ! string=='WOA23INT' + tmpReal = 0. ; ke = 0 ; dz_extra = 0. + do while (tmpReal size(woa23_dzi)) then + dz_extra = maximum_depth - tmpReal + exit + endif + tmpReal = tmpReal + woa23_dzi(ke) + enddo + elseif (index(trim(string),'WOA23INT:')==1) then ! string starts with 'WOA23INT:' + if (len_trim(string)==9) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'Expected string of form "WOA23INT:N" but got "'//trim(string)//'".') + ke = extract_integer(string(10:len_trim(string)),'',1) + if (ke>39 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05INT:N" N must 0 size(woa23_dzi)) dz(ke) = dz_extra elseif (index(trim(string),'WOA09')==1) then - if (len_trim(string)==5) then - tmpReal = 0. ; ke = 0 + if (len_trim(string)==5) then ! string=='WOA09' + tmpReal = 0. ; ke = 0 ; dz_extra = 0. do while (tmpReal size(woa09_dz_approx)) then + dz_extra = maximum_depth - tmpReal + exit + endif + tmpReal = tmpReal + woa09_dz_approx(ke) enddo - elseif (index(trim(string),'WOA09:')==1) then + elseif (index(trim(string),'WOA09:')==1) then ! string starts with 'WOA09:' if (len_trim(string)==6) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'Expected string of form "WOA09:N" but got "'//trim(string)//'".') ke = extract_integer(string(7:len_trim(string)),'',1) + if (ke>40 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05:N" N must 040 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & - 'For "WOA05:N" N must 0 size(woa09_dz_approx)) dz(ke) = dz_extra else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Unrecognized coordinate configuration"//trim(string)) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 0fdf80bf52..3c2c0af6df 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -5,7 +5,6 @@ module MOM_remapping ! Original module written by Laurent White, 2008.06.09 use MOM_error_handler, only : MOM_error, FATAL -use MOM_io, only : stdout, stderr use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 use regrid_edge_values, only : edge_values_explicit_h4cw @@ -38,6 +37,47 @@ module MOM_remapping !> The vintage of the expressions to use for remapping. Values below 20190101 result !! in the use of older, less accurate expressions. integer :: answer_date = 99991231 + !> If true, use the OM4 version of the remapping algorithm that makes poor assumptions + !! about the reconstructions in top and bottom layers of the source grid + logical :: om4_remap_via_sub_cells = .false. + + !> A negligibly small width for the purpose of cell reconstructions in the same units + !! as the h0 argument to remapping_core_h [H] + real :: h_neglect + !> A negligibly small width for the purpose of edge value calculations in the same units + !! as the h0 argument to remapping_core_h [H] + real :: h_neglect_edge +end type + +!> Class to assist in unit tests +type :: testing + private + !> True if any fail has been encountered since instantiation of "testing" + logical :: state = .false. + !> Count of tests checked + integer :: num_tests_checked = 0 + !> Count of tests failed + integer :: num_tests_failed = 0 + !> If true, be verbose and write results to stdout. Default True. + logical :: verbose = .true. + !> Error channel + integer :: stderr = 0 + !> Standard output channel + integer :: stdout = 6 + !> If true, stop instantly + logical :: stop_instantly = .false. + !> Record instances that fail + integer :: ifailed(100) = 0. + !> Record label of first instance that failed + character(len=:), allocatable :: label_first_fail + + contains + procedure :: test => test !< Update the testing state + procedure :: set => set !< Set attributes + procedure :: outcome => outcome !< Return current outcome + procedure :: summarize => summarize !< Summarize testing state + procedure :: real_arr => real_arr !< Compare array of reals + procedure :: int_arr => int_arr !< Compare array of integers end type ! The following routines are visible to the outside world @@ -63,8 +103,6 @@ module MOM_remapping integer, parameter :: INTEGRATION_PPM = 3 !< Piecewise Parabolic Method integer, parameter :: INTEGRATION_PQM = 5 !< Piecewise Quartic Method -character(len=40) :: mdl = "MOM_remapping" !< This module's name. - !> Documentation for external callers character(len=360), public :: remappingSchemesDoc = & "PCM (1st-order accurate)\n"//& @@ -82,15 +120,24 @@ module MOM_remapping !> Set parameters within remapping object subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & - check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018, answer_date) + check_reconstruction, check_remapping, force_bounds_in_subcell, & + om4_remap_via_sub_cells, answers_2018, answer_date, & + h_neglect, h_neglect_edge) type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), optional, intent(in) :: remapping_scheme !< Remapping scheme to use logical, optional, intent(in) :: boundary_extrapolation !< Indicate to extrapolate in boundary cells logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of cell + !! reconstructions in the same units as the h0 argument + !! to remapping_core_h [H] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of edge + !! value calculations in the same units as as the h0 + !! argument to remapping_core_h [H] if (present(remapping_scheme)) then call setReconstructionType( remapping_scheme, CS ) @@ -107,6 +154,9 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & if (present(force_bounds_in_subcell)) then CS%force_bounds_in_subcell = force_bounds_in_subcell endif + if (present(om4_remap_via_sub_cells)) then + CS%om4_remap_via_sub_cells = om4_remap_via_sub_cells + endif if (present(answers_2018)) then if (answers_2018) then CS%answer_date = 20181231 @@ -117,6 +167,12 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & if (present(answer_date)) then CS%answer_date = answer_date endif + if (present(h_neglect)) then + CS%h_neglect = h_neglect + endif + if (present(h_neglect_edge)) then + CS%h_neglect_edge = h_neglect_edge + endif end subroutine remapping_set_param @@ -141,23 +197,11 @@ subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_ex end subroutine extract_member_remapping_CS -!> Calculate edge coordinate x from cell width h -subroutine buildGridFromH(nz, h, x) - integer, intent(in) :: nz !< Number of cells - real, dimension(nz), intent(in) :: h !< Cell widths [H] - real, dimension(nz+1), intent(inout) :: x !< Edge coordinates starting at x(1)=0 [H] - ! Local variables - integer :: k - - x(1) = 0.0 - do k = 1,nz - x(k+1) = x(k) + h(k) - enddo - -end subroutine buildGridFromH - !> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. -subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge, PCM_cell) +!! +!! \todo Remove h_neglect argument by moving into remapping_CS +!! \todo Remove PCM_cell argument by adding new method in Recon1D class +subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, net_err, PCM_cell) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] @@ -165,44 +209,92 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg integer, intent(in) :: n1 !< Number of cells on target grid real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid [H] real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0 [H] - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value - !! calculations in the same units as h0 [H] + real, optional, intent(out) :: net_err !< Error in total column [A H] logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for !! cells in the source grid where this is true. ! Local variables + real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] + real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] + real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] + integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell + integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell + integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell + integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell + real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] + integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell + integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell + ! For error checking/debugging + logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues + real :: u02_err ! Integrated reconstruction error estimates [H A] real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] - real :: hNeglect, hNeglect_edge ! Negligibly small cell widths in the same units as h0 [H] integer :: iMethod ! An integer indicating the integration method used - integer :: k - - hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & - hNeglect, hNeglect_edge, PCM_cell ) + CS%h_neglect, CS%h_neglect_edge, PCM_cell ) - if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + if (CS%om4_remap_via_sub_cells) then - call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell, u1, uh_err ) + if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) - if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & - n1, h1, u1, iMethod, uh_err, "remapping_core_h") + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, h0_eff, isub_src + ! Sets: u_sub, uh_sub + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + force_bounds_in_target, u1, uh_err) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err + + if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, "remapping_core_h") + + else ! i.e. if (CS%om4_remap_via_sub_cells == .false.) + + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, h0_eff, isub_src + ! Sets: u_sub, uh_sub + call remap_src_to_sub_grid(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + force_bounds_in_target, u1, uh_err) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err + + endif + + if (present(net_err)) net_err = uh_err end subroutine remapping_core_h !> Remaps column of values u0 on grid h0 to implied grid h1 !! where the interfaces of h1 differ from those of h0 by dx. -subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_edge ) +subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] @@ -210,30 +302,34 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed integer, intent(in) :: n1 !< Number of cells on target grid real, dimension(n1+1), intent(in) :: dx !< Cell widths on target grid [H] real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0 [H]. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value - !! calculations in the same units as h0 [H]. + ! Local variables + real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] + real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] + real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] + integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell + integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell + integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell + integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell + real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] + integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell + integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell + ! For error checking/debugging + logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues + real :: u02_err ! Integrated reconstruction error estimates [H A] real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] real, dimension(n1) :: h1 !< Cell widths on target grid [H] real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] - real :: hNeglect, hNeglect_edge ! Negligibly small thicknesses [H] integer :: iMethod ! An integer indicating the integration method used integer :: k - hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge - call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod,& - hNeglect, hNeglect_edge ) + CS%h_neglect, CS%h_neglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) ! This is a temporary step prior to switching to remapping_core_h() do k = 1, n1 @@ -243,10 +339,26 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed h1(k) = max( 0., dx(k+1) - dx(k) ) endif enddo - call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell, u1, uh_err ) -! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, dx, iMethod, u1, hNeglect ) -! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1, hNeglect ) + + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, h0_eff, isub_src + ! Sets: u_sub, uh_sub + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + force_bounds_in_target, u1, uh_err) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & n1, h1, u1, iMethod, uh_err, "remapping_core_w") @@ -266,19 +378,23 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial [A] real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial [A H-1] integer, intent(out) :: iMethod !< Integration method - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h0 [H] - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value - !! calculations in the same units as h0 [H] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose + !! of edge value calculations in the same units as h0 [H]. + !! The default is h_neglect. logical, optional, intent(in) :: PCM_cell(n0) !< If present, use PCM remapping for !! cells from the source grid where this is true. ! Local variables + real :: h_neg_edge ! A negligibly small width for the purpose of edge value + ! calculations in the same units as h0 [H] integer :: local_remapping_scheme integer :: k, n + h_neg_edge = h_neglect ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge + ! Reset polynomial ppoly_r_E(:,:) = 0.0 ppoly_r_S(:,:) = 0.0 @@ -315,7 +431,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_CW ) ! identical to REMAPPING_PPM_HYBGEN - call edge_values_explicit_h4cw( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call edge_values_explicit_h4cw( n0, h0, u0, ppoly_r_E, h_neg_edge ) call PPM_monotonicity( n0, u0, ppoly_r_E ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) if ( CS%boundary_extrapolation ) then @@ -323,14 +439,14 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & endif iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_H4 ) - call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neg_edge, answer_date=CS%answer_date ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_IH4 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neg_edge, answer_date=CS%answer_date ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) @@ -349,7 +465,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect, answer_date=CS%answer_date ) call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect, & answer_date=CS%answer_date ) @@ -359,7 +475,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & endif iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) - call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect, answer_date=CS%answer_date ) call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect, & answer_date=CS%answer_date ) @@ -387,15 +503,14 @@ end subroutine build_reconstructions_1d !> Checks that edge values and reconstructions satisfy bounds subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & - ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + ppoly_r_coefs, ppoly_r_E) integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] integer, intent(in) :: deg !< Degree of polynomial reconstruction logical, intent(in) :: boundary_extrapolation !< Extrapolate at boundaries if true - real, dimension(n0,deg+1),intent(in) :: ppoly_r_coefs !< Coefficients of polynomial [A] - real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge value of polynomial [A] - real, dimension(n0,2), intent(in) :: ppoly_r_S !< Edge slope of polynomial [A H-1] + real, dimension(n0,deg+1),intent(in) :: ppoly_r_coefs !< Coefficients of polynomial [A] + real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge value of polynomial [A] ! Local variables integer :: i0, n real :: u_l, u_c, u_r ! Cell averages [A] @@ -457,26 +572,39 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & end subroutine check_reconstructions_1d -!> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating -!! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the -!! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. -subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & - force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] - real, intent(in) :: u0(n0) !< Source cell averages (size n0) [A] - real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] - integer, intent(in) :: method !< Remapping scheme to use - logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded - real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] - real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] - real, optional, intent(out) :: ah_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] - integer, optional, intent(out) :: aisub_src(n0+n1+1) !< i_sub_src - integer, optional, intent(out) :: aiss(n0) !< isrc_start - integer, optional, intent(out) :: aise(n0) !< isrc_ens +!> Returns the intersection of source and targets grids along with and auxiliary lists or indices. +!! +!! For source grid with thicknesses h0(1:n0) and target grid with thicknesses h1(1:n1) the intersection +!! or "subgrid" has thicknesses h_sub(1:n0+n1+1). +!! h0 and h1 must have the same units. h_sub will return with the same units as h0 and h1. +!! +!! Notes on the algorithm: +!! Internally, grids are defined by the interfaces (although we describe grids via thicknesses for accuracy). +!! The intersection or union of two grids is thus defined by the super set of both lists of interfaces. +!! Because both source and target grids can contain vanished cells, we do not eliminate repeated +!! interfaces from the union. +!! That is, the total number of interfaces of the sub-cells is equal to the total numer of interfaces of +!! the source grid (n0+1) plus the total number of interfaces of the target grid (n1+1), i.e. n0+n1+2. +!! Whenever target and source interfaces align, then the retention of identical interfaces leads to a +!! vanished subcell. +!! The remapping uses a common point of reference to the left (top) so there is always a vanished subcell +!! at the left (top). +!! If the total column thicknesses are the same, then the right (bottom) interfaces are also aligned and +!! so the last subcell will also be vanished. +subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + real, intent(out) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(out) :: h0_eff(n0) !< Effective thickness of source cells [H] + integer, intent(out) :: isrc_start(n0) !< Index of first sub-cell within each source cell + integer, intent(out) :: isrc_end(n0) !< Index of last sub-cell within each source cell + integer, intent(out) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell + integer, intent(out) :: itgt_start(n1) !< Index of first sub-cell within each target cell + integer, intent(out) :: itgt_end(n1) !< Index of last sub-cell within each target cell + integer, intent(out) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell ! Local variables integer :: i_sub ! Index of sub-cell integer :: i0 ! Index into h0(1:n0), source column @@ -485,41 +613,16 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer :: i_start1 ! Used to record which sub-cells map to target cells integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] - real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] - real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] - real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] - integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell - integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell - integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell - integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell - real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] - real, dimension(n0) :: u0_min ! Minimum value of reconstructions in source cell [A] - real, dimension(n0) :: u0_max ! Minimum value of reconstructions in source cell [A] - integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell - integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell - real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] real :: h0_supply, h1_supply ! The amount of width available for constructing sub-cells [H] real :: dh ! The width of the sub-cell [H] - real :: duh ! The total amount of accumulated stuff (u*h) [A H] real :: dh0_eff ! Running sum of source cell thickness [H] ! For error checking/debugging - logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues - logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues - logical, parameter :: debug_bounds = .false. ! For debugging overshoots etc. - integer :: k, i0_last_thick_cell - real :: h0tot, h1tot, h2tot ! Summed thicknesses used for debugging [H] - real :: h0err, h1err, h2err ! Estimates of round-off errors used for debugging [H] - real :: u02_err, u0err, u1err, u2err ! Integrated reconstruction error estimates [H A] - real :: u0tot, u1tot, u2tot ! Integrated reconstruction values [H A] - real :: u_orig ! The original value of the reconstruction in a cell [A] - real :: u0min, u0max, u1min, u1max, u2min, u2max ! Minimum and maximum values of reconstructions [A] + integer :: i0_last_thick_cell logical :: src_has_volume !< True if h0 has not been consumed logical :: tgt_has_volume !< True if h1 has not been consumed i0_last_thick_cell = 0 do i0 = 1, n0 - u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) - u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) if (h0(i0)>0.) i0_last_thick_cell = i0 enddo @@ -645,12 +748,61 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth tgt_has_volume = .false. endif else - stop 'remap_via_sub_cells: THIS SHOULD NEVER HAPPEN!' + stop 'intersect_src_tgt_grids: THIS SHOULD NEVER HAPPEN!' endif enddo +end subroutine intersect_src_tgt_grids + +!> Remaps column of n0 values u0 on grid h0 to subgrid h_sub +!! +!! This includes an error for the scenario where the source grid is much thicker than +!! the target grid and extrapolation is needed. +subroutine remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(in) :: h0_eff(n0) !< Effective thickness of source cells [H] + integer, intent(in) :: isrc_start(n0) !< Index of first sub-cell within each source cell + integer, intent(in) :: isrc_end(n0) !< Index of last sub-cell within each source cell + integer, intent(in) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell + integer, intent(in) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + real, intent(out) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + real, intent(out) :: u02_err !< Integrated reconstruction error estimates [A H] + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + real :: u0_min(n0), u0_max(n0) !< Min/max of u0 for each source cell [A] + ! For error checking/debugging + logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues + integer :: i0_last_thick_cell + real :: u_orig ! The original value of the reconstruction in a cell [A] + + i0_last_thick_cell = 0 + do i0 = 1, n0 + u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) + u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub xa = 0. dh0_eff = 0. uh_sub(1) = 0. @@ -676,19 +828,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth xb = 1. u_sub(i_sub) = u0(i0) endif - if (debug_bounds) then - if (method<5 .and.(u_sub(i_sub)u0_max(i0))) then - write(0,*) 'Sub cell average is out of bounds',i_sub,'method=',method - write(0,*) 'xa,xb: ',xa,xb - write(0,*) 'Edge values: ',ppoly0_E(i0,:),'mean',u0(i0) - write(0,*) 'a_c: ',(u0(i0)-ppoly0_E(i0,1))+(u0(i0)-ppoly0_E(i0,2)) - write(0,*) 'Polynomial coeffs: ',ppoly0_coefs(i0,:) - write(0,*) 'Bounds min=',u0_min(i0),'max=',u0_max(i0) - write(0,*) 'Average: ',u_sub(i_sub),'rel to min=',u_sub(i_sub)-u0_min(i0),'rel to max=',u_sub(i_sub)-u0_max(i0) - call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& - 'Sub-cell average is out of bounds!' ) - endif - endif if (force_bounds_in_subcell) then ! These next two lines should not be needed but when using PQM we found roundoff ! can lead to overshoots. These lines sweep issues under the rug which need to be @@ -716,6 +855,149 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub + do i0 = 1, i0_last_thick_cell + i_max = isrc_max(i0) + dh_max = h_sub(i_max) + if (dh_max > 0.) then + ! duh will be the sum of sub-cell integrals within the source cell except for the thickest sub-cell. + duh = 0. + do i_sub = isrc_start(i0), isrc_end(i0) + if (i_sub /= i_max) duh = duh + uh_sub(i_sub) + enddo + uh_sub(i_max) = u0(i0)*h0(i0) - duh + u02_err = u02_err + max( abs(uh_sub(i_max)), abs(u0(i0)*h0(i0)), abs(duh) ) + endif + enddo + endif + +end subroutine remap_src_to_sub_grid_om4 + +!> Remaps column of n0 values u0 on grid h0 to subgrid h_sub +subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + integer, intent(in) :: isrc_start(n0) !< Index of first sub-cell within each source cell + integer, intent(in) :: isrc_end(n0) !< Index of last sub-cell within each source cell + integer, intent(in) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell + integer, intent(in) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + real, intent(out) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + real, intent(out) :: u02_err !< Integrated reconstruction error estimates [A H] + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + real :: u0_min(n0), u0_max(n0) !< Min/max of u0 for each source cell [A] + ! For error checking/debugging + logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues + integer :: i0_last_thick_cell + real :: u_orig ! The original value of the reconstruction in a cell [A] + + i0_last_thick_cell = 0 + do i0 = 1, n0 + u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) + u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub + xa = 0. + dh0_eff = 0. + u02_err = 0. + do i_sub = 1, n0+n1 + + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + if (force_bounds_in_subcell) then + ! These next two lines should not be needed but when using PQM we found roundoff + ! can lead to overshoots. These lines sweep issues under the rug which need to be + ! properly .. later. -AJA + u_orig = u_sub(i_sub) + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) + endif + uh_sub(i_sub) = dh * u_sub(i_sub) + + if (isub_src(i_sub+1) /= i0) then + ! If the next sub-cell is in a different source cell, reset the position counters + dh0_eff = 0. + xa = 0. + else + xa = xb ! Next integral will start at end of last + endif + + enddo + i_sub = n0+n1+1 + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + if (force_bounds_in_subcell) then + ! These next two lines should not be needed but when using PQM we found roundoff + ! can lead to overshoots. These lines sweep issues under the rug which need to be + ! properly .. later. -AJA + u_orig = u_sub(i_sub) + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) + endif + uh_sub(i_sub) = dh * u_sub(i_sub) + + if (adjust_thickest_subcell) then + ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within + ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub do i0 = 1, i0_last_thick_cell i_max = isrc_max(i0) dh_max = h_sub(i_max) @@ -731,7 +1013,36 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth enddo endif +end subroutine remap_src_to_sub_grid + +!> Remaps column of n0+n1+1 values usub on sub-grid h_sub to targets on grid h1 +subroutine remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, & + itgt_start, itgt_end, force_bounds_in_target, u1, uh_err) + integer, intent(in) :: n0 !< Number of cells in source grid + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(in) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(in) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + integer, intent(in) :: itgt_start(n1) !< Index of first sub-cell within each target cell + integer, intent(in) :: itgt_end(n1) !< Index of last sub-cell within each target cell + logical, intent(in) :: force_bounds_in_target !< Force sub-cell values to be bounded + real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] + real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] + ! Local variables + integer :: i1 ! tgt loop index + integer :: i_sub ! index to sub-layer + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: u1min, u1max ! Minimum and maximum values of reconstructions [A] + real :: u_orig ! The original value of the reconstruction in a cell prior to bounding [A] + + u1min = 0. ! Not necessary, but avoids an overzealous compiler ... + u1max = 0. ! ... warning about uninitialized variables + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err uh_err = 0. do i1 = 1, n1 if (h1(i1) > 0.) then @@ -765,91 +1076,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth endif enddo - ! Check errors and bounds - if (debug_bounds) then - call measure_input_bounds( n0, h0, u0, ppoly0_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) - call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) - call measure_output_bounds( n0+n1+1, h_sub, u_sub, h2tot, h2err, u2tot, u2err, u2min, u2max ) - if (method<5) then ! We except PQM until we've debugged it - if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err+u02_err .and. abs(h1tot-h0tot)u0err+u2err+u02_err .and. abs(h2tot-h0tot)u0max) ) then - write(0,*) 'method = ',method - write(0,*) 'Source to sub-cells:' - write(0,*) 'H: h0tot=',h0tot,'h2tot=',h2tot,'dh=',h2tot-h0tot,'h0err=',h0err,'h2err=',h2err - if (abs(h2tot-h0tot)>h0err+h2err) & - write(0,*) 'H non-conservation difference=',h2tot-h0tot,'allowed err=',h0err+h2err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u2tot=',u2tot,'duh=',u2tot-u0tot,'u0err=',u0err,'u2err=',u2err,& - 'adjustment err=',u02_err - if (abs(u2tot-u0tot)>u0err+u2err) & - write(0,*) 'U non-conservation difference=',u2tot-u0tot,'allowed err=',u0err+u2err,' <-----!' - write(0,*) 'Sub-cells to target:' - write(0,*) 'H: h2tot=',h2tot,'h1tot=',h1tot,'dh=',h1tot-h2tot,'h2err=',h2err,'h1err=',h1err - if (abs(h1tot-h2tot)>h2err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h2tot,'allowed err=',h2err+h1err,' <-----!' - write(0,*) 'UH: u2tot=',u2tot,'u1tot=',u1tot,'duh=',u1tot-u2tot,'u2err=',u2err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u2tot)>u2err+u1err) & - write(0,*) 'U non-conservation difference=',u1tot-u2tot,'allowed err=',u2err+u1err,' <-----!' - write(0,*) 'Source to target:' - write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & - write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' - write(0,*) 'U: u0min=',u0min,'u1min=',u1min,'u2min=',u2min - if (u1minu0max) write(0,*) 'U2 maximum overshoot=',u2max-u0max,' <-----!' - write(0,'(a3,6a24,2a3)') 'k','h0','left edge','u0','right edge','h1','u1','is','ie' - do k = 1, max(n0,n1) - if (k<=min(n0,n1)) then - write(0,'(i3,1p6e24.16,2i3)') k,h0(k),ppoly0_E(k,1),u0(k),ppoly0_E(k,2),h1(k),u1(k),itgt_start(k),itgt_end(k) - elseif (k>n0) then - write(0,'(i3,96x,1p2e24.16,2i3)') k,h1(k),u1(k),itgt_start(k),itgt_end(k) - else - write(0,'(i3,1p4e24.16)') k,h0(k),ppoly0_E(k,1),u0(k),ppoly0_E(k,2) - endif - enddo - write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' - do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly0_coefs(k,:) - enddo - write(0,'(a3,3a24,a3,2a24)') 'k','Sub-cell h','Sub-cell u','Sub-cell hu','i0','xa','xb' - xa = 0. - dh0_eff = 0. - do k = 1, n0+n1+1 - dh = h_sub(k) - i0 = isub_src(k) - dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell - xb = dh0_eff / h0_eff(i0) ! This expression yields xa <= xb <= 1.0 - xb = min(1., xb) ! This is only needed when the total target column is wider than the source column - write(0,'(i3,1p3e24.16,i3,1p2e24.16)') k,h_sub(k),u_sub(k),uh_sub(k),i0,xa,xb - if (k<=n0+n1) then - if (isub_src(k+1) /= i0) then - dh0_eff = 0.; xa = 0. - else - xa = xb - endif - endif - enddo - call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& - 'Remapping result is inconsistent!' ) - endif - endif ! method<5 - endif ! debug_bounds - - ! Include the error remapping from source to sub-cells in the estimate of total remapping error - uh_err = uh_err + u02_err - - if (present(ah_sub)) ah_sub(1:n0+n1+1) = h_sub(1:n0+n1+1) - if (present(aisub_src)) aisub_src(1:n0+n1+1) = isub_src(1:n0+n1+1) - if (present(aiss)) aiss(1:n0) = isrc_start(1:n0) - if (present(aise)) aise(1:n0) = isrc_end(1:n0) - -end subroutine remap_via_sub_cells +end subroutine remap_sub_to_tgt_grid !> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, mask_edges) @@ -942,6 +1169,7 @@ subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) k_dest = 0 h_dest_rem = 0. h_src_rem = 0. + uh_src_rem = 0. src_ran_out = .false. do while(.true.) @@ -997,8 +1225,8 @@ end subroutine reintegrate_column !! separation dh. real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: u0(:) !< Cell means [A] - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial [A] + real, intent(in) :: u0(n0) !< Cell means [A] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] integer, intent(in) :: method !< Remapping scheme to use integer, intent(in) :: i0 !< Source cell index @@ -1013,6 +1241,7 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] + u_ave = 0. ! Avoids warnings about "potentially unset values"; u_ave is always calculated for legitimate schemes if (xb > xa) then select case ( method ) case ( INTEGRATION_PCM ) @@ -1091,6 +1320,7 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x + xa * ( ppoly0_coefs(i0,4) & + xa * ppoly0_coefs(i0,5) ) ) ) case default + u_ave = 0. call MOM_error( FATAL,'The selected integration method is invalid' ) end select endif @@ -1257,7 +1487,9 @@ end subroutine dzFromH1H2 !> Constructor for remapping control structure subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & - check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018, answer_date) + check_reconstruction, check_remapping, force_bounds_in_subcell, & + om4_remap_via_sub_cells, answers_2018, answer_date, & + h_neglect, h_neglect_edge) ! Arguments type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), intent(in) :: remapping_scheme !< Remapping scheme to use @@ -1265,13 +1497,20 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of cell + !! reconstructions in the same units as h0 [H] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of edge + !! value calculations in the same units as h0 [H]. ! Note that remapping_scheme is mandatory for initialize_remapping() call remapping_set_param(CS, remapping_scheme=remapping_scheme, boundary_extrapolation=boundary_extrapolation, & check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018, answer_date=answer_date) + force_bounds_in_subcell=force_bounds_in_subcell, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answers_2018=answers_2018, answer_date=answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) end subroutine initialize_remapping @@ -1339,463 +1578,825 @@ end subroutine end_remapping logical function remapping_unit_tests(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables - integer, parameter :: n0 = 4, n1 = 3, n2 = 6 - real :: h0(n0), x0(n0+1), u0(n0) ! Thicknesses [H], interface heights [H] and values [A] for profile 0 - real :: h1(n1), x1(n1+1), u1(n1) ! Thicknesses [H], interface heights [H] and values [A] for profile 1 - real :: dx1(n1+1) ! Interface height changes for profile 1 [H] - real :: h2(n2), x2(n2+1), u2(n2) ! Thicknesses [H], interface heights [H] and values [A] for profile 2 - data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom [A] - data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 [H] - data h1 /3*1./ ! 3 uniform layers with total depth of 3 [H] - data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 [H] + integer :: n0, n1, n2 + real, allocatable :: h0(:), h1(:), h2(:) ! Thicknesses for test columns [H] + real, allocatable :: u0(:), u1(:), u2(:) ! Values for test profiles [A] + real, allocatable :: dx1(:) ! Change in interface position [H] type(remapping_CS) :: CS !< Remapping control structure real, allocatable, dimension(:,:) :: ppoly0_E ! Edge values of polynomials [A] real, allocatable, dimension(:,:) :: ppoly0_S ! Edge slopes of polynomials [A H-1] real, allocatable, dimension(:,:) :: ppoly0_coefs ! Coefficients of polynomials [A] + real, allocatable, dimension(:) :: h_sub, h0_eff ! Subgrid and effective source thicknesses [H] + real, allocatable, dimension(:) :: u_sub, uh_sub ! Subgrid values and totals [A, A H] + real :: u02_err ! Error in remaping [A] + integer, allocatable, dimension(:) :: isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ! Indices integer :: answer_date ! The vintage of the expressions to test - integer :: i - real, parameter :: hNeglect_dflt = 1.0e-30 ! A thickness [H ~> m or kg m-2] that can be - ! added to thicknesses in a denominator without - ! changing the numerical result, except where - ! a division by zero would otherwise occur. real :: err ! Errors in the remapped thicknesses [H] or values [A] real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H] - logical :: thisTest, v, fail + type(testing) :: test ! Unit testing convenience functions + integer :: i, om4 + character(len=4) :: om4_tag + + call test%set( verbose=verbose ) ! Sets the verbosity flag in test - v = verbose answer_date = 20190101 ! 20181231 - h_neglect = hNeglect_dflt - h_neglect_edge = hNeglect_dflt ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 + h_neglect = 1.0e-30 + h_neglect_edge = h_neglect ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 - write(stdout,*) '==== MOM_remapping: remapping_unit_tests =================' - remapping_unit_tests = .false. ! Normally return false + if (verbose) write(test%stdout,*) ' ===== MOM_remapping: remapping_unit_tests =================' - thisTest = .false. - call buildGridFromH(n0, h0, x0) - do i=1,n0+1 - err=x0(i)-0.75*real(i-1) - if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 1' - remapping_unit_tests = remapping_unit_tests .or. thisTest - call buildGridFromH(n1, h1, x1) - do i=1,n1+1 - err=x1(i)-real(i-1) - if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 2' - remapping_unit_tests = remapping_unit_tests .or. thisTest + ! This line carries out tests on some older remapping schemes. + call test%test( remapping_attic_unit_tests(verbose), 'attic remapping unit tests' ) - thisTest = .false. - call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date) - if (verbose) write(stdout,*) 'h0 (test data)' - if (verbose) call dumpGrid(n0,h0,x0,u0) + if (verbose) write(test%stdout,*) ' - - - - - 1st generation tests - - - - -' - call dzFromH1H2( n0, h0, n1, h1, dx1 ) - call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1, h_neglect, h_neglect_edge) - do i=1,n1 - err=u1(i)-8.*(0.5*real(1+n1)-real(i)) - if (abs(err)>real(n1-1)*epsilon(err)) thisTest = .true. - enddo - if (verbose) write(stdout,*) 'h1 (by projection)' - if (verbose) call dumpGrid(n1,h1,x1,u1) - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapping_core_w()' - remapping_unit_tests = remapping_unit_tests .or. thisTest + call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) - thisTest = .false. - allocate(ppoly0_E(n0,2)) - allocate(ppoly0_S(n0,2)) - allocate(ppoly0_coefs(n0,CS%degree+1)) + ! Profile 0: 4 layers of thickness 0.75 and total depth 3, with du/dz=8 + n0 = 4 + allocate( h0(n0), u0(n0) ) + h0 = (/0.75, 0.75, 0.75, 0.75/) + u0 = (/9., 3., -3., -9./) - ppoly0_E(:,:) = 0.0 - ppoly0_S(:,:) = 0.0 - ppoly0_coefs(:,:) = 0.0 + ! Profile 1: 3 layers of thickness 1.0 and total depth 3 + n1 = 3 + allocate( h1(n1), u1(n1), dx1(n1+1) ) + h1 = (/1.0, 1.0, 1.0/) - call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=answer_date ) - call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + ! Profile 2: 6 layers of thickness 0.5 and total depth 3 + n2 = 6 + allocate( h2(n2), u2(n2) ) + h2 = (/0.5, 0.5, 0.5, 0.5, 0.5, 0.5/) - thisTest = .false. - call buildGridFromH(n2, h2, x2) + ! Mapping u1 from h1 to h2 + call dzFromH1H2( n0, h0, n1, h1, dx1 ) + call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1 ) + call test%real_arr(3, u1, (/8.,0.,-8./), 'remapping_core_w() PPM_H4') - if (verbose) write(stdout,*) 'Via sub-cells' - thisTest = .false. - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n2, h2, INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(n2,h2,x2,u2) + allocate(ppoly0_E(n0,2), ppoly0_S(n0,2), ppoly0_coefs(n0,CS%degree+1)) + ppoly0_E(:,:) = 0.0 + ppoly0_S(:,:) = 0.0 + ppoly0_coefs(:,:) = 0.0 - do i=1,n2 - err=u2(i)-8./2.*(0.5*real(1+n2)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remap_via_sub_cells() 2' - remapping_unit_tests = remapping_unit_tests .or. thisTest - - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - 6, (/.125,.125,.125,.125,.125,.125/), INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(6,h2,x2,u2) - - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(3,h2,x2,u2) - - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' - - write(stdout,*) '===== MOM_remapping: new remapping_unit_tests ==================' - - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) - allocate(ppoly0_coefs(5,6)) - allocate(ppoly0_E(5,2)) - allocate(ppoly0_S(5,2)) - - call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') - - call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') - - call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & - h_neglect=1e-10, answer_date=answer_date ) + call initialize_remapping(CS, 'PPM_H4', force_bounds_in_subcell=.false., answer_date=answer_date) + + call remapping_core_h( CS, n0, h0, u0, n2, h2, u2, net_err=err ) + call test%real_arr(6, u2, (/10.,6.,2.,-2.,-6.,-10./), 'remapping_core_h() 2') + + call remapping_core_h( CS, n0, h0, u0, 6, (/.125,.125,.125,.125,.125,.125/), u2, net_err=err ) + call test%real_arr(6, u2, (/11.5,10.5,9.5,8.5,7.5,6.5/), 'remapping_core_h() 3') + + call remapping_core_h( CS, n0, h0, u0, 3, (/2.25,1.5,1./), u2, net_err=err ) + call test%real_arr(3, u2, (/3.,-10.5,-12./), 'remapping_core_h() 4') + + deallocate(h0, u0, h1, u1, h2, u2, ppoly0_E, ppoly0_S, ppoly0_coefs) + call end_remapping(CS) + + ! =============================================== + ! This section tests the reconstruction functions + ! =============================================== + if (verbose) write(test%stdout,*) ' - - - - - reconstruction tests - - - - -' + + allocate( ppoly0_coefs(5,6), ppoly0_E(5,2), ppoly0_S(5,2), u2(2) ) + + call PCM_reconstruction(3, (/1.,2.,4./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:) ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') + + call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') + + call edge_values_explicit_h4(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), & + ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) ! The next two tests currently fail due to roundoff, but pass when given a reasonable tolerance. - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) - remapping_unit_tests = remapping_unit_tests .or. thisTest - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest + call test%real_arr(5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) + call test%real_arr(5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) + ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') + call test%real_arr(5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & h_neglect=1e-10, answer_date=answer_date ) ! The next two tests are now passing when answer_date >= 20190101, but otherwise only work to roundoff. - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest + call test%real_arr(5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) + call test%real_arr(5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') + call test%real_arr(5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') + call test%real_arr(5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') + call test%real_arr(5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') ppoly0_E(:,1) = (/0.,0.,6.,10.,15./) ppoly0_E(:,2) = (/0.,6.,12.,17.,15./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), & ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') - - call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefs(1:4,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') - call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefs(1:4,:), & - 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') - - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + call test%real_arr(5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') + call test%real_arr(5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') + call test%real_arr(5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs, u2) + + ! ============================================================== + ! This section tests the components of remapping_core_h() + ! ============================================================== + + if (verbose) write(test%stdout,*) ' - - - - - remapping algororithm tests - - - - -' + + ! Test 1: n0=2, n1=3 Maps uniform grids with one extra target layer and no implicitly-vanished interior sub-layers + ! h_src = | 3 | 3 | + ! h_tgt = | 2 | 2 | 2 | + ! h_sub = |0| 2 | 1 | 1 | 2 |0| + ! isrc_start |1 | 4 | + ! isrc_end | 3 | 5 | + ! isrc_max | 2 | 5 | + ! itgt_start |1 | 3 | 5 | + ! itgt_end | 2 | 4 | 6| + ! isub_src |1| 1 | 1 | 2 | 2 |2| + allocate( h_sub(6), h0_eff(2), isrc_start(2), isrc_end(2), isrc_max(2), itgt_start(3), itgt_end(3), isub_src(6) ) + call intersect_src_tgt_grids( 2, (/3., 3./), & ! n0, h0 + 3, (/2., 2., 2./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 1: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 3 | 3 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 2 |" + call test%real_arr(6, h_sub, (/0.,2.,1.,1.,2.,0./), 'h_sub') + call test%real_arr(2, h0_eff, (/3.,3./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,4/), 'isrc_start') + call test%int_arr(2, isrc_end, (/3,5/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,5/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,3,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/2,4,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,1,2,2,2/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 2: n0=3, n1=2 Reverses "test 1" with more source than target layers + ! h_src = | 2 | 2 | 2 | + ! h_tgt = | 3 | 3 | + ! h_sub = |0| 2 | 1 | 1 | 2 |0| + ! isrc_start |1 | 3 | 5 | + ! isrc_end | 2 | 4 | 5 | + ! isrc_max | 2 | 4 | 5 | + ! itgt_start |1 | 4 | + ! itgt_end | 3 | 6| + ! isub_src |1| 1 | 2 | 2 | 3 |3| + allocate( h_sub(6), h0_eff(3), isrc_start(3), isrc_end(3), isrc_max(3), itgt_start(2), itgt_end(2), isub_src(6) ) + call intersect_src_tgt_grids( 3, (/2., 2., 2./), & ! n0, h0 + 2, (/3., 3./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 2: n0=3, n1=2" + if (verbose) write(test%stdout,*) " h_src = | 2 | 2 | 2 |" + if (verbose) write(test%stdout,*) " h_tgt = | 3 | 3 |" + call test%real_arr(6, h_sub, (/0.,2.,1.,1.,2.,0./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,2.,2./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,3,5/), 'isrc_start') + call test%int_arr(3, isrc_end, (/2,4,5/), 'isrc_end') + call test%int_arr(3, isrc_max, (/2,4,5/), 'isrc_max') + call test%int_arr(2, itgt_start, (/1,4/), 'itgt_start') + call test%int_arr(2, itgt_end, (/3,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,3,3/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 3: n0=2, n1=3 With aligned interfaces that lead to implicitly-vanished interior sub-layers + n0 = 2 ; n1 = 3 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. , 5. /) + h0 = (/ 2. , 4. /) + h1 = (/ 2. , 2. , 2. /) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_tgt = |<- 2 ->|<- 2 ->|<- 2 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! isrc_start |1 |3 | + ! isrc_end | 2 | 5 | + ! isrc_max | 2 | 5 | + ! itgt_start |1 | 4 | 5 | + ! itgt_end | 3| 4 | 6| + ! isub_src |1| 1 |2| 2 | 2 |2| + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 3: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 2 | 4 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 2 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,2.,0./), 'h_sub') + call test%real_arr(2, h0_eff, (/2.,4./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,3/), 'isrc_start') + call test%int_arr(2, isrc_end, (/2,5/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,5/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,4,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/3,4,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! u_src = | 2 | 5 | + ! edge = |1 3|3 7| + ! u_sub = |1| 2 |3| 4 | 6 |7| + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub') + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! u_sub = |1| 2 |3| 4 | 6 |7| + ! h_tgt = |<- 2 ->|<- 2 ->|<- 2 ->| + ! u_tgt = | 2 | 4 | 6 | + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .false., u1, u02_err) + call test%real_arr(3, u1, (/2.,4.,6./), 'u1') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .true., u1, u02_err) + call test%real_arr(3, u1, (/2.,4.,6./), 'u1.b') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 4: n0=2, n1=3 Incomplete target column, sum(h_tgt)|<- 4 ->| + ! h_tgt = |<- 2 ->|<- 2 ->|< 1 >| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! isrc_start |1 |3 | + ! isrc_end | 2 | 6 | + ! isrc_max | 2 | 4 | + ! itgt_start |1 | 4 | 5 | + ! itgt_end | 3| 4 | 5 | + ! isub_src |1| 1 |2| 2 | 2 | 2 | + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 4: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 2 | 4 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 1 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,1.,1./), 'h_sub') + call test%real_arr(2, h0_eff, (/2.,3./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,3/), 'isrc_start') + call test%int_arr(2, isrc_end, (/2,6/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,4/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,4,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/3,4,5/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<-1->|<-1->| + ! u_src = | 2 | 5 | + ! edge = |1 3|3 7| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6.5 | + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, & + 3, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6.5/), 'u_sub') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 5: n0=3, n1=2 Target column exceeds source column, sum(h_tgt)>sum(h_src), useful for diagnostics + n0 = 3 ; n1 = 2 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. , 4. , 5.5 /) + h0 = (/ 2. , 2. , 1. /) + h1 = (/ 2. , 4. /) + ! h_src = |<- 2 ->|<- 2 ->|< 1 >| + ! h_tgt = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! isrc_start |1 |3 | 5 | + ! isrc_end | 2 | 4 | 5 | + ! isrc_max | 2 | 4 | 5 | + ! itgt_start |1 | 4 | + ! itgt_end | 3| 6 | + ! isub_src |1| 1 |2| 2 | 3 | 3 | + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 5: n0=3, n1=2" + if (verbose) write(test%stdout,*) " h_src = | 2 | 2 | 1 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 4 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,1.,1./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,2.,1./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,3,5/), 'isrc_start') + call test%int_arr(3, isrc_end, (/2,4,5/), 'isrc_end') + call test%int_arr(3, isrc_max, (/2,4,5/), 'isrc_max') + call test%int_arr(2, itgt_start, (/1,4/), 'itgt_start') + call test%int_arr(2, itgt_end, (/3,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,3,3/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 2 ->|< 1 >| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! u_src = | 2 | 4 | 5.5 | + ! edge = |1 3|3 5|5 6| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub') + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | + ! h_tgt = |<- 2 ->|<- 4 ->| + ! u_tgt = | 2 | 4 7/8 | + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .false., u1, u02_err) + call test%real_arr(2, u1, (/2.,4.875/), 'u1') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .true., u1, u02_err) + call test%real_arr(2, u1, (/2.,4.875/), 'u1.b') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 6: n0=3, n1=5 Source and targets with vanished layers + n0 = 3 ; n1 = 5 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. ,3., 4. /) + h0 = (/ 2. ,0., 2. /) + h1 = (/ 1. ,0., 1. ,0., 2. /) + ! h_src = |<- 2 ->|0|<- 2 ->| + ! h_tgt = |<- 1 ->|0|<- 1 ->|0|<- 2 ->| + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! isrc_start |1 |5|6 | + ! isrc_end | 4 |5| 8 | + ! isrc_max | 4 |5| 8 | + ! itgt_start |1 |3| 4 |7| 8 | + ! itgt_end | 2 |3| 6|7| 9| + ! isub_src |1| 1 |1| 1 |2|3|3| 3 |3| + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 6: n0=3, n1=5" + if (verbose) write(test%stdout,*) " h_src = | 2 |0| 2 |" + if (verbose) write(test%stdout,*) " h_tgt = | 1 |0| 1 |0| 2 |" + call test%real_arr(9, h_sub, (/0.,1.,0.,1.,0.,0.,0.,2.,0./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,0.,2./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,5,6/), 'isrc_start') + call test%int_arr(3, isrc_end, (/4,5,8/), 'isrc_end') + call test%int_arr(3, isrc_max, (/4,5,8/), 'isrc_max') + call test%int_arr(5, itgt_start, (/1,3,4,7,8/), 'itgt_start') + call test%int_arr(5, itgt_end, (/2,3,6,7,9/), 'itgt_end') + call test%int_arr(9, isub_src, (/1,1,1,1,2,3,3,3,3/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|0|<- 2 ->| + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! u_src = | 2 |3| 4 | + ! edge = |1 3|3|3 5| + ! u_sub = |1| 1.5 |2| 2.5 |3|3|3| 4 |5| + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(9, u_sub, (/1.,1.5,2.,2.5,3.,3.,3.,4.,5./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(9, u_sub, (/1.,1.5,2.,2.5,3.,3.,3.,4.,5./), 'u_sub') + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! u_sub = |1| 1.5 |2| 2.5 |3|3|3| 4 |5| + ! h_tgt = |<- 1 ->|0|<- 1 ->|0|<- 2 ->| + ! u_tgt = | 1.5 |2| 2.5 |3| 4 | + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .false., u1, u02_err) + call test%real_arr(5, u1, (/1.5,2.,2.5,3.,4./), 'u1') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .true., u1, u02_err) + call test%real_arr(5, u1, (/1.5,2.,2.5,3.,4./), 'u1.b') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! ============================================================ + ! This section tests remapping_core_h() + ! ============================================================ + if (verbose) write(test%stdout,*) '- - - - - - - - - - remapping_core_h() tests - - - - - - - - -' + + allocate(u2(2)) + + call initialize_remapping(CS, 'PLM', force_bounds_in_subcell=.false., answer_date=answer_date) + + ! Remapping to just the two interior layers yields the same values as u_src(2:3) + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,1./), u2) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11 om4') + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,1./), u2) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') + + ! Remapping to two layers that are deeper. For the bottom layer of thickness 4, + ! the first 1/4 has average 2, the remaining 3/4 has the bottom edge value or 1 + ! yield ing and average or 1.25 + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,4./), u2) + call test%real_arr(2, u2, (/4.,1.25/), 'PLM: remapped h=0110->h=14 om4') + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,4./), u2) + call test%real_arr(2, u2, (/4.,1.25/), 'PLM: remapped h=0110->h=14') + + ! Remapping to two layers with lowest layer not reach the bottom. + ! Here, the bottom layer samples top half of source yeilding 2.5. + ! Note: OM4 used the value as if the target layer was the same thickness as source. + call remapping_set_param(CS, om4_remap_via_sub_cells=.true.) + call remapping_core_h(CS, 4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), 2, (/4.,2./), u2) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0440->h=42 om4 (with known bug)') + call remapping_set_param(CS, om4_remap_via_sub_cells=.false.) + call remapping_core_h(CS, 4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), 2, (/4.,2./), u2) + call test%real_arr(2, u2, (/4.,2.5/), 'PLM: remapped h=0440->h=42') + + ! Remapping to two layers with no layers sampling the bottom source layer + ! The first layer samples the top half of u1, yielding 4.5 + ! The second layer samples the next quarter of u1, yielding 3.75 + call remapping_set_param(CS, om4_remap_via_sub_cells=.true.) + call remapping_core_h(CS, 4, (/0.,5.,5.,0./), (/5.,4.,2.,1./), 2, (/2.,2./), u2) + call test%real_arr(2, u2, (/4.5,3.5/), 'PLM: remapped h=0880->h=21 om4 (with known bug)') + call remapping_set_param(CS, om4_remap_via_sub_cells=.false.) + call remapping_core_h(CS, 4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), 2, (/2.,1./), u2) + call test%real_arr(2, u2, (/4.5,3.75/), 'PLM: remapped h=0440->h=21') + + deallocate(u2) + + ! Profile 0: 8 layers, 1x top/2x bottom vanished, and the rest with thickness 1.0, total depth 5, u(z) = 1 + z + n0 = 8 + allocate( h0(n0), u0(n0) ) + h0 = (/0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0/) + u0 = (/1.0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.0, 6.0/) + allocate( u1(8) ) + + call initialize_remapping(CS, 'PLM', answer_date=99990101, h_neglect=1.e-17, h_neglect_edge=1.e-2) + + do om4 = 0, 1 + if ( om4 == 0 ) then + CS%om4_remap_via_sub_cells = .false. + om4_tag(:) = ' ' + else + CS%om4_remap_via_sub_cells = .true. + om4_tag(:) = ' om4' + endif - ! This line carries out tests on some older remapping schemes. - remapping_unit_tests = remapping_unit_tests .or. remapping_attic_unit_tests(verbose) + ! Unchanged grid + call remapping_core_h( CS, n0, h0, u0, 8, [0.,1.,1.,1.,1.,1.,0.,0.], u1) + call test%real_arr(8, u1, (/1.0,1.5,2.5,3.5,4.5,5.5,6.0,6.0/), 'PLM: remapped h=01111100->h=01111100'//om4_tag) + + ! Removing vanished layers (unchanged values for non-vanished layers, layer centers 0.5, 1.5, 2.5, 3.5, 4.5) + call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,1.], u1) + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.5/), 'PLM: remapped h=01111100->h=11111'//om4_tag) + + ! Remapping to variable thickness layers (layer centers 0.25, 1.0, 2.25, 4.0) + call remapping_core_h( CS, n0, h0, u0, 4, [0.5,1.,1.5,2.], u1) + call test%real_arr(4, u1, (/1.25,2.,3.25,5./), 'PLM: remapped h=01111100->h=h1t2'//om4_tag) + + ! Remapping to variable thickness + vanished layers (layer centers 0.25, 1.0, 1.5, 2.25, 4.0) + call remapping_core_h( CS, n0, h0, u0, 6, [0.5,1.,0.,1.5,2.,0.], u1) + call test%real_arr(6, u1, (/1.25,2.,2.5,3.25,5.,6./), 'PLM: remapped h=01111100->h=h10t20'//om4_tag) + + ! Remapping to deeper water column (layer centers 0.75, 2.25, 3., 5., 8.) + call remapping_core_h( CS, n0, h0, u0, 5, [1.5,1.5,0.,4.,2.], u1) + call test%real_arr(5, u1, (/1.75,3.25,4.,5.5,6./), 'PLM: remapped h=01111100->h=tt02'//om4_tag) + + ! Remapping to slightly shorter water column (layer centers 0.5, 1.5, 2.5,, 3.5, 4.25) + call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,0.5], u1) + if ( om4 == 0 ) then + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.25/), 'PLM: remapped h=01111100->h=1111h') + else + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.5/), 'PLM: remapped h=01111100->h=1111h om4 (known bug)') + endif + + ! Remapping to much shorter water column (layer centers 0.25, 0.5, 1.) + call remapping_core_h( CS, n0, h0, u0, 3, [0.5,0.,1.], u1) + if ( om4 == 0 ) then + call test%real_arr(3, u1, (/1.25,1.5,2./), 'PLM: remapped h=01111100->h=h01') + else + call test%real_arr(3, u1, (/1.25,1.5,1.875/), 'PLM: remapped h=01111100->h=h01 om4 (known bug)') + endif - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + enddo ! om4 - write(stdout,*) '=== MOM_remapping: interpolation and reintegration unit tests ===' - if (verbose) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + call end_remapping(CS) + deallocate( h0, u0, u1 ) - fail = test_interp(verbose, 'Identity: 3 layer', & + ! ============================================================ + ! This section tests interpolation and reintegration functions + ! ============================================================ + if (verbose) write(test%stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + + call test_interp(test, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/1.,2.,3.,4./), & 3, (/1.,2.,3./), (/1.,2.,3.,4./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'A: 3 layer to 2', & + call test_interp(test, 'A: 3 layer to 2', & 3, (/1.,1.,1./), (/1.,2.,3.,4./), & 2, (/1.5,1.5/), (/1.,2.5,4./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'B: 2 layer to 3', & + call test_interp(test, 'B: 2 layer to 3', & 2, (/1.5,1.5/), (/1.,4.,7./), & 3, (/1.,1.,1./), (/1.,3.,5.,7./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'C: 3 layer (vanished middle) to 2', & + call test_interp(test, 'C: 3 layer (vanished middle) to 2', & 3, (/1.,0.,2./), (/1.,2.,2.,3./), & 2, (/1.,2./), (/1.,2.,3./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'D: 3 layer (deep) to 3', & + call test_interp(test, 'D: 3 layer (deep) to 3', & 3, (/1.,2.,3./), (/1.,2.,4.,7./), & 2, (/2.,2./), (/1.,3.,5./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'E: 3 layer to 3 (deep)', & + call test_interp(test, 'E: 3 layer to 3 (deep)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 3, (/2.,3.,4./), (/1.,3.,6.,8./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'F: 3 layer to 4 with vanished top/botton', & + call test_interp(test, 'F: 3 layer to 4 with vanished top/botton', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 4, (/0.,2.,5.,0./), (/0.,1.,3.,8.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'Fs: 3 layer to 4 with vanished top/botton (shallow)', & + call test_interp(test, 'Fs: 3 layer to 4 with vanished top/botton (shallow)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 4, (/0.,2.,4.,0./), (/0.,1.,3.,7.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'Fd: 3 layer to 4 with vanished top/botton (deep)', & + call test_interp(test, 'Fd: 3 layer to 4 with vanished top/botton (deep)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 4, (/0.,2.,6.,0./), (/0.,1.,3.,8.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - if (verbose) write(stdout,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' + if (verbose) write(test%stdout,*) ' - - - - - reintegration tests - - - - -' - fail = test_reintegrate(verbose, 'Identity: 3 layer', & + call test_reintegrate(test, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/-5.,2.,1./), & 3, (/1.,2.,3./), (/-5.,2.,1./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'A: 3 layer to 2', & + call test_reintegrate(test, 'A: 3 layer to 2', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,3./), (/-4.,2./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'A: 3 layer to 2 (deep)', & + call test_reintegrate(test, 'A: 3 layer to 2 (deep)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,4./), (/-4.,2./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'A: 3 layer to 2 (shallow)', & + call test_reintegrate(test, 'A: 3 layer to 2 (shallow)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,2./), (/-4.,1.5/) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'B: 3 layer to 4 with vanished top/bottom', & + call test_reintegrate(test, 'B: 3 layer to 4 with vanished top/bottom', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 4, (/0.,3.,3.,0./), (/0.,-4.,2.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'C: 3 layer to 4 with vanished top//middle/bottom', & + call test_reintegrate(test, 'C: 3 layer to 4 with vanished top//middle/bottom', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 5, (/0.,3.,0.,3.,0./), (/0.,-4.,0.,2.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'D: 3 layer to 3 (vanished)', & + call test_reintegrate(test, 'D: 3 layer to 3 (vanished)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 3, (/0.,0.,0./), (/0.,0.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3', & + call test_reintegrate(test, 'D: 3 layer (vanished) to 3', & 3, (/0.,0.,0./), (/-5.,2.,1./), & 3, (/2.,2.,2./), (/0., 0., 0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3 (vanished)', & + call test_reintegrate(test, 'D: 3 layer (vanished) to 3 (vanished)', & 3, (/0.,0.,0./), (/-5.,2.,1./), & - 3, (/0.,0.,0./), (/0., 0., 0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail + 3, (/0.,0.,0./), (/0.,0.,0./) ) - fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3 (vanished)', & + call test_reintegrate(test, 'D: 3 layer (vanished) to 3 (vanished)', & 3, (/0.,0.,0./), (/0.,0.,0./), & - 3, (/0.,0.,0./), (/0., 0., 0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail + 3, (/0.,0.,0./), (/0.,0.,0./) ) - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + remapping_unit_tests = test%summarize('remapping_unit_tests') end function remapping_unit_tests -!> Returns true if any cell of u and u_true are not identical. Returns false otherwise. -logical function test_answer(verbose, n, u, u_true, label, tol) - logical, intent(in) :: verbose !< If true, write results to stdout +!> Test if interpolate_column() produces the wrong answer +subroutine test_interp(test, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces [A] + ! Local variables + real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] + + ! Interpolate from src to dest + call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) + call test%real_arr(ndest, u_dest, u_true, msg) +end subroutine test_interp + +!> Test if reintegrate_column() produces the wrong answer +subroutine test_reintegrate(test, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] + ! Local variables + real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] + + ! Interpolate from src to dest + call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) + call test%real_arr(ndest, uh_dest, uh_true, msg) + +end subroutine test_reintegrate + +! ========================================================================================= +! The following provide the function for the testing_type helper class + +!> Update the state with "test" +subroutine test(this, state, label) + class(testing), intent(inout) :: this !< This testing class + logical, intent(in) :: state !< True to indicate a fail, false otherwise + character(len=*), intent(in) :: label !< Message + + this%num_tests_checked = this%num_tests_checked + 1 + if (state) then + this%state = .true. + this%num_tests_failed = this%num_tests_failed + 1 + this%ifailed( this%num_tests_failed ) = this%num_tests_checked + if (this%num_tests_failed == 1) this%label_first_fail = label + endif + if (this%stop_instantly .and. this%state) stop 1 +end subroutine test + +!> Set attributes +subroutine set(this, verbose, stdout, stderr, stop_instantly) + class(testing), intent(inout) :: this !< This testing class + logical, optional, intent(in) :: verbose !< True or false setting to assign to verbosity + integer, optional, intent(in) :: stdout !< The stdout channel to use + integer, optional, intent(in) :: stderr !< The stderr channel to use + logical, optional, intent(in) :: stop_instantly !< If true, stop immediately on error detection + + if (present(verbose)) then + this%verbose = verbose + endif + if (present(stdout)) then + this%stdout = stdout + endif + if (present(stderr)) then + this%stderr = stderr + endif + if (present(stop_instantly)) then + this%stop_instantly = stop_instantly + endif +end subroutine set + +!> Returns state +logical function outcome(this) + class(testing), intent(inout) :: this !< This testing class + outcome = this%state +end function outcome + +!> Summarize results +logical function summarize(this, label) + class(testing), intent(inout) :: this !< This testing class + character(len=*), intent(in) :: label !< Message + integer :: i + + if (this%state) then + write(this%stdout,'(a," : ",a,", ",i4," failed of ",i4," tested")') & + 'FAIL', trim(label), this%num_tests_failed, this%num_tests_checked + write(this%stdout,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,this%num_tests_failed) + write(this%stdout,'(a,a)') 'First failed test: ',trim(this%label_first_fail) + write(this%stderr,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,this%num_tests_failed) + write(this%stderr,'(a,a)') 'First failed test: ',trim(this%label_first_fail) + write(this%stderr,'(a," : ",a)') trim(label),'FAILED' + else + write(this%stdout,'(a," : ",a,", all ",i4," tests passed")') & + 'Pass', trim(label), this%num_tests_checked + endif + summarize = this%state +end function summarize + +!> Compare u_test to u_true, report, and return true if a difference larger than tol is measured +!! +!! If in verbose mode, display results to stdout +!! If a difference is measured, display results to stdout and stderr +subroutine real_arr(this, n, u_test, u_true, label, tol) + class(testing), intent(inout) :: this !< This testing class integer, intent(in) :: n !< Number of cells in u - real, dimension(n), intent(in) :: u !< Values to test [A] + real, dimension(n), intent(in) :: u_test !< Values to test [A] real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) [A] character(len=*), intent(in) :: label !< Message real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] ! Local variables - real :: tolerance ! The tolerance for differences between u and u_true [A] integer :: k + logical :: this_test + real :: tolerance, err ! Tolerance for differences, and error [A] + + tolerance = 0.0 + if (present(tol)) tolerance = tol + this_test = .false. - tolerance = 0.0 ; if (present(tol)) tolerance = tol - test_answer = .false. + ! Scan for any mismatch between u_test and u_true do k = 1, n - if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. + if (abs(u_test(k) - u_true(k)) > tolerance) this_test = .true. enddo - if (test_answer .or. verbose) then - write(stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label + + ! If either being verbose, or an error was measured then display results + if (this_test .or. this%verbose) then + write(this%stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label + if (this_test) write(this%stderr,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label do k = 1, n - if (abs(u(k) - u_true(k)) > tolerance) then - write(stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' - write(stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' + err = u_test(k) - u_true(k) + if (abs(err) > tolerance) then + write(this%stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & + ' err=', err, ' <--- WRONG' + write(this%stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & + ' err=', err, ' <--- WRONG' else - write(stdout,'(i4,1p2e24.16)') k,u(k),u_true(k) + write(this%stdout,'(i4,1p2e24.16)') k, u_test(k), u_true(k) endif enddo endif -end function test_answer - -!> Returns true if a test of interpolate_column() produces the wrong answer -logical function test_interp(verbose, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) - logical, intent(in) :: verbose !< If true, write results to stdout - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] - real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] - real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces [A] + call this%test( this_test, label ) ! Updates state and counters in this +end subroutine real_arr + +!> Compare i_test to i_true and report and return true if a difference is found +!! +!! If in verbose mode, display results to stdout +!! If a difference is measured, display results to stdout and stderr +subroutine int_arr(this, n, i_test, i_true, label) + class(testing), intent(inout) :: this !< This testing class + integer, intent(in) :: n !< Number of cells in u + integer, dimension(n), intent(in) :: i_test !< Values to test [A] + integer, dimension(n), intent(in) :: i_true !< Values to test against (correct answer) [A] + character(len=*), intent(in) :: label !< Message ! Local variables - real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] integer :: k - real :: error ! The difference between the evaluated and expected solutions [A] + logical :: this_test - ! Interpolate from src to dest - call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) + this_test = .false. - test_interp = .false. - do k=1,ndest+1 - if (u_dest(k)/=u_true(k)) test_interp = .true. + ! Scan for any mismatch between u_test and u_true + do k = 1, n + if (i_test(k) .ne. i_true(k)) this_test = .true. enddo - if (verbose .or. test_interp) then - write(stdout,'(2a)') ' Test: ',msg - write(stdout,'(a3,3(a24))') 'k','u_result','u_true','error' - do k=1,ndest+1 - error = u_dest(k)-u_true(k) - if (error==0.) then - write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) - else - write(stdout,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - endif - enddo - endif -end function test_interp - -!> Returns true if a test of reintegrate_column() produces the wrong answer -logical function test_reintegrate(verbose, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) - logical, intent(in) :: verbose !< If true, write results to stdout - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] - real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] - real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] - ! Local variables - real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] - integer :: k - real :: error ! The difference between the evaluated and expected solutions [A H] - ! Interpolate from src to dest - call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) - - test_reintegrate = .false. - do k=1,ndest - if (uh_dest(k)/=uh_true(k)) test_reintegrate = .true. - enddo - if (verbose .or. test_reintegrate) then - write(stdout,'(2a)') ' Test: ',msg - write(stdout,'(a3,3(a24))') 'k','uh_result','uh_true','error' - do k=1,ndest - error = uh_dest(k)-uh_true(k) - if (error==0.) then - write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) - else - write(stdout,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - endif - enddo - endif -end function test_reintegrate - -!> Convenience function for printing grid to screen -subroutine dumpGrid(n,h,x,u) - integer, intent(in) :: n !< Number of cells - real, dimension(:), intent(in) :: h !< Cell thickness [H] - real, dimension(:), intent(in) :: x !< Interface delta [H] - real, dimension(:), intent(in) :: u !< Cell average values [A] - integer :: i - write(stdout,'("i=",20i10)') (i,i=1,n+1) - write(stdout,'("x=",20es10.2)') (x(i),i=1,n+1) - write(stdout,'("i=",5x,20i10)') (i,i=1,n) - write(stdout,'("h=",5x,20es10.2)') (h(i),i=1,n) - write(stdout,'("u=",5x,20es10.2)') (u(i),i=1,n) -end subroutine dumpGrid + if (this%verbose) then + write(this%stdout,'(a12," : calculated =",30i3)') label, i_test + write(this%stdout,'(12x," correct =",30i3)') i_true + if (this_test) write(this%stdout,'(3x,a,8x,"error =",30i3)') 'FAIL --->', i_test(:) - i_true(:) + endif + if (this_test) then + write(this%stderr,'(a12," : calculated =",30i3)') label, i_test + write(this%stderr,'(12x," correct =",30i3)') i_true + write(this%stderr,'(" FAIL ---> error =",30i3)') i_test(:) - i_true(:) + endif + + call this%test( this_test, label ) ! Updates state and counters in this +end subroutine int_arr end module MOM_remapping diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index 7889966135..d2051cc702 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -31,7 +31,7 @@ subroutine P1M_interpolation( N, h, u, edge_values, ppoly_coef, h_neglect, answe real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified !! piecewise polynomial coefficients, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 6039b197fb..e9c234db32 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -10,9 +10,6 @@ module P3M_functions public P3M_interpolation public P3M_boundary_extrapolation -real, parameter :: hNeglect_dflt = 1.E-30 !< Default value of a negligible cell thickness -real, parameter :: hNeglect_edge_dflt = 1.E-10 !< Default value of a negligible edge thickness - contains !> Set up a piecewise cubic interpolation from cell averages and estimated @@ -32,7 +29,7 @@ subroutine P3M_interpolation( N, h, u, edge_values, ppoly_S, ppoly_coef, h_negle real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1]. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -66,7 +63,7 @@ subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, an real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -79,15 +76,9 @@ subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, an real :: h_l, h_c, h_r ! left, center and right cell widths [H] real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] real :: slope ! retained PLM slope [A H-1] - real :: eps - real :: hNeglect ! A negligibly small thickness [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - - eps = 1e-10 ! 1. Bound edge values (boundary cells are assumed to be local extrema) - call bound_edge_values( N, h, u, edge_values, hNeglect, answer_date=answer_date ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answer_date=answer_date ) ! 2. Systematically average discontinuous edge values call average_discontinuous_edge_values( N, edge_values ) @@ -127,9 +118,9 @@ subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, an endif ! Compute limited slope - sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) - sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) - sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + h_neglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + h_neglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + h_neglect ) if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) @@ -197,10 +188,10 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H] - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of finding edge values [H] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose + !! of finding edge values [H]. The default is h_neglect. ! Local variables integer :: i0, i1 logical :: monotonic ! boolean indicating whether the cubic is monotonic @@ -210,10 +201,9 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef real :: u0_l, u0_r ! Left and right edge values [A] real :: u1_l, u1_r ! Left and right edge slopes [A H-1] real :: slope ! The cell center slope [A H-1] - real :: hNeglect, hNeglect_edge ! Negligibly small thickness [H] + real :: hNeglect_edge ! Negligibly small thickness [H] - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect_edge = hNeglect_edge_dflt ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge + hNeglect_edge = h_neglect ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge ! ----- Left boundary ----- i0 = 1 @@ -229,7 +219,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef u1_r = b / h1 ! derivative evaluated at xi = 0.0, expressed w.r.t. x ! Limit the right slope by the PLM limited slope - slope = 2.0 * ( u1 - u0 ) / ( h0 + hNeglect ) + slope = 2.0 * ( u1 - u0 ) / ( h0 + h_neglect ) if ( abs(u1_r) > abs(slope) ) then u1_r = slope endif @@ -242,7 +232,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef ! edge value and slope by computing the parabola as determined by ! the right edge value and slope and the boundary cell average u0_l = 3.0 * u0 + 0.5 * h0*u1_r - 2.0 * u0_r - u1_l = ( - 6.0 * u0 - 2.0 * h0*u1_r + 6.0 * u0_r) / ( h0 + hNeglect ) + u1_l = ( - 6.0 * u0 - 2.0 * h0*u1_r + 6.0 * u0_r) / ( h0 + h_neglect ) ! Check whether the edge values are monotonic. For example, if the left edge ! value is larger than the right edge value while the slope is positive, the @@ -286,10 +276,10 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef b = ppoly_coef(i0,2) c = ppoly_coef(i0,3) d = ppoly_coef(i0,4) - u1_l = (b + 2*c + 3*d) / ( h0 + hNeglect ) ! derivative evaluated at xi = 1.0 + u1_l = (b + 2*c + 3*d) / ( h0 + h_neglect ) ! derivative evaluated at xi = 1.0 ! Limit the left slope by the PLM limited slope - slope = 2.0 * ( u1 - u0 ) / ( h1 + hNeglect ) + slope = 2.0 * ( u1 - u0 ) / ( h1 + h_neglect ) if ( abs(u1_l) > abs(slope) ) then u1_l = slope endif @@ -302,7 +292,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef ! edge value and slope by computing the parabola as determined by ! the left edge value and slope and the boundary cell average u0_r = 3.0 * u1 - 0.5 * h1*u1_l - 2.0 * u0_l - u1_r = ( 6.0 * u1 - 2.0 * h1*u1_l - 6.0 * u0_l) / ( h1 + hNeglect ) + u1_r = ( 6.0 * u1 - 2.0 * h1*u1_l - 6.0 * u0_l) / ( h1 + h_neglect ) ! Check whether the edge values are monotonic. For example, if the right edge ! value is smaller than the left edge value while the slope is positive, the diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index c0c4516fe2..6d6afd3885 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -12,8 +12,6 @@ module PLM_functions public PLM_slope_wa public PLM_slope_cw -real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness - contains !> Returns a limited PLM slope following White and Adcroft, 2008, in the same arbitrary @@ -195,7 +193,7 @@ subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) !! with the same units as u [A]. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly !! with the same units as u [A]. - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h [H] @@ -208,15 +206,12 @@ subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) real :: almost_one ! A value that is slightly smaller than 1 [nondim] real, dimension(N) :: slp ! The first guess at the normalized tracer slopes [A] real, dimension(N) :: mslp ! The monotonized normalized tracer slopes [A] - real :: hNeglect ! A negligibly small width used in cell reconstructions [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect almost_one = 1. - epsilon(slope) ! Loop on interior cells do k = 2,N-1 - slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), hNeglect, u(k-1), u(k), u(k+1)) + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), h_neglect, u(k-1), u(k), u(k+1)) enddo ! end loop on interior cells ! Boundary cells use PCM. Extrapolation is handled after monotonization. @@ -277,17 +272,14 @@ subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle !! with the same units as u [A]. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly !! with the same units as u [A]. - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h [H] ! Local variables real :: slope ! retained PLM slope for a normalized cell width [A] - real :: hNeglect ! A negligibly small width used in cell reconstructions [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Extrapolate from 2 to 1 to estimate slope - slope = - PLM_extrapolate_slope( h(2), h(1), hNeglect, u(2), u(1) ) + slope = - PLM_extrapolate_slope( h(2), h(1), h_neglect, u(2), u(1) ) edge_values(1,1) = u(1) - 0.5 * slope edge_values(1,2) = u(1) + 0.5 * slope @@ -296,7 +288,7 @@ subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) ! Extrapolate from N-1 to N to estimate slope - slope = PLM_extrapolate_slope( h(N-1), h(N), hNeglect, u(N-1), u(N) ) + slope = PLM_extrapolate_slope( h(N-1), h(N), h_neglect, u(N-1), u(N) ) edge_values(N,1) = u(N) - 0.5 * slope edge_values(N,2) = u(N) + 0.5 * slope diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index ef6841f635..c11ec6e741 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -15,13 +15,6 @@ module PPM_functions public PPM_reconstruction, PPM_boundary_extrapolation, PPM_monotonicity -!> A tiny width that is so small that adding it to cell widths does not -!! change the value due to a computational representation. It is used -!! to avoid division by zero. -!! @note This is a dimensional parameter and should really include a unit -!! conversion. -real, parameter :: hNeglect_dflt = 1.E-30 - contains !> Builds quadratic polynomials coefficients from cell mean and edge values. @@ -31,7 +24,7 @@ subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect, answ real, dimension(N), intent(in) :: u !< Cell averages in arbitrary coordinates [A] real, dimension(N,2), intent(inout) :: edge_values !< Edge values [A] real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -64,7 +57,7 @@ subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answer_date ) real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -190,7 +183,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle real, dimension(:), intent(in) :: u !< cell averages (size N) [A] real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] ! Local variables @@ -204,9 +197,6 @@ subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle ! the cell being worked on [A] real :: slope ! The normalized slope [A] real :: exp1, exp2 ! Temporary expressions [A2] - real :: hNeglect ! A negligibly small width used in cell reconstructions [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! ----- Left boundary ----- i0 = 1 @@ -219,7 +209,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system b = ppoly_coef(i1,2) - u1_r = b *((h0+hNeglect)/(h1+hNeglect)) ! derivative evaluated at xi = 0.0, + u1_r = b *((h0+h_neglect)/(h1+h_neglect)) ! derivative evaluated at xi = 0.0, ! expressed w.r.t. xi (local coord. system) ! Limit the right slope by the PLM limited slope @@ -273,7 +263,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle b = ppoly_coef(i0,2) c = ppoly_coef(i0,3) u1_l = (b + 2*c) ! derivative evaluated at xi = 1.0 - u1_l = u1_l * ((h1+hNeglect)/(h0+hNeglect)) + u1_l = u1_l * ((h1+h_neglect)/(h0+h_neglect)) ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index ef42fb9f01..418a4b47a2 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -9,8 +9,6 @@ module PQM_functions public PQM_reconstruction, PQM_boundary_extrapolation, PQM_boundary_extrapolation_v1 -real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness - contains !> Reconstruction by quartic polynomials within each cell. @@ -24,7 +22,7 @@ subroutine PQM_reconstruction( N, h, u, edge_values, edge_slopes, ppoly_coef, h_ real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -78,7 +76,7 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, dimension(:,:), intent(inout) :: edge_slopes !< Potentially modified edge slopes [A H-1] - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -98,12 +96,9 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat real :: sqrt_rho ! The square root of rho [A] real :: gradient1, gradient2 ! Normalized gradients [A] real :: x1, x2 ! Fractional inflection point positions in a cell [nondim] - real :: hNeglect ! A negligibly small width for the purpose of cell reconstructions [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Bound edge values - call bound_edge_values( N, h, u, edge_values, hNeglect, answer_date=answer_date ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answer_date=answer_date ) ! Make discontinuous edge values monotonic (thru averaging) call check_discontinuous_edge_values( N, u, edge_values ) @@ -132,9 +127,9 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat u_r = u(k+1) ! Compute limited slope - sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) - sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) - sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + h_neglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + h_neglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + h_neglect ) if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) @@ -272,8 +267,8 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge - u1_l = ( 10.0 * u_c - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h_c + hNeglect ) - u1_r = ( -10.0 * u_c + 6.0 * u0_r + 4.0 * u0_l ) / ( h_c + hNeglect ) + u1_l = ( 10.0 * u_c - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h_c + h_neglect ) + u1_r = ( -10.0 * u_c + 6.0 * u0_r + 4.0 * u0_l ) / ( h_c + h_neglect ) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -283,13 +278,13 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat u1_l = 0.0 u0_r = 5.0 * u_c - 4.0 * u0_l - u1_r = 20.0 * (u_c - u0_l) / ( h_c + hNeglect ) + u1_r = 20.0 * (u_c - u0_l) / ( h_c + h_neglect ) elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*u_c - 3.0*u0_r) / 2.0 - u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + hNeglect) + u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + h_neglect) endif @@ -297,8 +292,8 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge - u1_r = ( -10.0 * u_c + 8.0 * u0_r + 2.0 * u0_l ) / (3.0 * h_c + hNeglect) - u1_l = ( 10.0 * u_c - 4.0 * u0_r - 6.0 * u0_l ) / (h_c + hNeglect) + u1_r = ( -10.0 * u_c + 8.0 * u0_r + 2.0 * u0_l ) / (3.0 * h_c + h_neglect) + u1_l = ( 10.0 * u_c - 4.0 * u0_r - 6.0 * u0_l ) / (h_c + h_neglect) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -308,13 +303,13 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat u1_l = 0.0 u0_r = ( 5.0 * u_c - 3.0 * u0_l ) / 2.0 - u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + hNeglect) + u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + h_neglect) elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = 5.0 * u_c - 4.0 * u0_r - u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + hNeglect) + u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + h_neglect) endif @@ -506,7 +501,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] ! Local variables integer :: i0, i1 @@ -526,9 +521,6 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo real :: sqrt_rho ! The square root of rho [A] real :: gradient1, gradient2 ! Normalized gradients [A] real :: x1, x2 ! Fractional inflection point positions in a cell [nondim] - real :: hNeglect ! A negligibly small width for the purpose of cell reconstructions [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! ----- Left boundary (TOP) ----- i0 = 1 @@ -541,7 +533,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo ! Compute real slope and express it w.r.t. local coordinate system ! within boundary cell - slope = 2.0 * ( u1 - u0 ) / ( ( h0 + h1 ) + hNeglect ) + slope = 2.0 * ( u1 - u0 ) / ( ( h0 + h1 ) + h_neglect ) slope = slope * h0 ! The right edge value and slope of the boundary cell are taken to be the @@ -550,12 +542,12 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo b = ppoly_coef(i1,2) u0_r = a ! edge value - u1_r = b / (h1 + hNeglect) ! edge slope (w.r.t. global coord.) + u1_r = b / (h1 + h_neglect) ! edge slope (w.r.t. global coord.) ! Compute coefficient for rational function based on mean and right ! edge value and slope if (u1_r /= 0.) then ! HACK by AJA - beta = 2.0 * ( u0_r - um ) / ( (h0 + hNeglect)*u1_r) - 1.0 + beta = 2.0 * ( u0_r - um ) / ( (h0 + h_neglect)*u1_r) - 1.0 else beta = 0. endif ! HACK by AJA @@ -574,10 +566,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo ! compute corresponding slope. if ( abs(um-u0_l) < abs(um-u_plm) ) then u1_l = 2.0 * ( br - ar*beta) - u1_l = u1_l / (h0 + hNeglect) + u1_l = u1_l / (h0 + h_neglect) else u0_l = u_plm - u1_l = slope / (h0 + hNeglect) + u1_l = slope / (h0 + h_neglect) endif ! Monotonize quartic @@ -635,8 +627,8 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge - u1_l = ( 10.0 * um - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h0 + hNeglect) - u1_r = ( -10.0 * um + 6.0 * u0_r + 4.0 * u0_l ) / (h0 + hNeglect) + u1_l = ( 10.0 * um - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h0 + h_neglect) + u1_r = ( -10.0 * um + 6.0 * u0_r + 4.0 * u0_l ) / (h0 + h_neglect) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -646,13 +638,13 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo u1_l = 0.0 u0_r = 5.0 * um - 4.0 * u0_l - u1_r = 20.0 * (um - u0_l) / ( h0 + hNeglect ) + u1_r = 20.0 * (um - u0_l) / ( h0 + h_neglect ) elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*um - 3.0*u0_r) / 2.0 - u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + hNeglect ) + u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + h_neglect ) endif diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index ddc569e45e..1e5474770a 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -119,7 +119,7 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_ real, optional, intent(in) :: zScale !< Scaling factor from the input coordinate thicknesses in [Z ~> m] !! to desired units for zInterface, perhaps GV%Z_to_H in which !! case this has units of [H Z-1 ~> nondim or kg m-3] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + real, intent(in) :: h_neglect !< A negligibly small width for the purpose of !! cell reconstruction [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of !! edge value calculation [H ~> m or kg m-2] @@ -175,8 +175,8 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_ ( p_col(nz) - p_col(1) ) enddo ! Remap from original h and T,S to get T,S_col_new - call remapping_core_h(remapCS, nz, h(:), T, CS%nk, h_col_new, T_col_new, h_neglect, h_neglect_edge) - call remapping_core_h(remapCS, nz, h(:), S, CS%nk, h_col_new, S_col_new, h_neglect, h_neglect_edge) + call remapping_core_h(remapCS, nz, h(:), T, CS%nk, h_col_new, T_col_new) + call remapping_core_h(remapCS, nz, h(:), S, CS%nk, h_col_new, S_col_new) call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, & h_col_new, T_col_new, S_col_new, p_col_new, r_col_new, RiA_new, h_neglect, h_neglect_edge) do k= 2,CS%nk @@ -225,7 +225,7 @@ subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h, real, dimension(nz+1), intent(out) :: RiAnom !< The interface density anomaly !! w.r.t. the interface target !! densities [R ~> kg m-3] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + real, intent(in) :: h_neglect !< A negligibly small width for the purpose of !! cell reconstruction [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of !! edge value calculation [H ~> m or kg m-2] diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 3ed769f4e4..c967687dc8 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -105,7 +105,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & !! units as depth) [H ~> m or kg m-2] real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same !! units as depth) [H ~> m or kg m-2] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose + real, intent(in) :: h_neglect !< A negligibly small width for the purpose !! of cell reconstructions [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose !! of edge value calculations [H ~> m or kg m-2] @@ -201,7 +201,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ real, dimension(nz), intent(in) :: S !< S for column [S ~> ppt] type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces [Z ~> m] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h [Z ~> m] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width @@ -272,9 +272,9 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ h1(k) = x1(k+1) - x1(k) enddo - call remapping_core_h(remapCS, nz, h0, S, nz, h1, S_tmp, h_neglect, h_neglect_edge) + call remapping_core_h(remapCS, nz, h0, S, nz, h1, S_tmp) - call remapping_core_h(remapCS, nz, h0, T, nz, h1, T_tmp, h_neglect, h_neglect_edge) + call remapping_core_h(remapCS, nz, h0, T, nz, h1, T_tmp) ! Compute the deviation between two successive grids deviation = 0.0 diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 8aaeb12654..54cec45cba 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -18,15 +18,10 @@ module regrid_edge_values public edge_values_implicit_h4, edge_values_implicit_h6 public edge_slopes_implicit_h3, edge_slopes_implicit_h5 -! The following parameters are used to avoid singular matrices for boundary -! extrapolation. The are needed only in the case where thicknesses vanish +! The following parameter is used to avoid singular matrices for boundary +! extrapolation. It is needed only in the case where thicknesses vanish ! to a small enough values such that the eigenvalues of the matrix can not ! be separated. -! Specifying a dimensional parameter value, as is done here, is a terrible idea. -real, parameter :: hNeglect_edge_dflt = 1.e-10 !< The default value for cut-off minimum - !! thickness for sum(h) in edge value inversions -real, parameter :: hNeglect_dflt = 1.e-30 !< The default value for cut-off minimum - !! thickness for sum(h) in other calculations real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) [nondim] contains @@ -47,20 +42,16 @@ subroutine bound_edge_values( N, h, u, edge_val, h_neglect, answer_date ) real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_val !< Potentially modified edge values [A]; the !! second index is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] or [A] real :: slope_x_h ! retained PLM slope times half grid step [A] - real :: hNeglect ! A negligible thickness [H]. logical :: use_2018_answers ! If true use older, less accurate expressions. integer :: k, km1, kp1 ! Loop index and the values to either side. use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) - if (use_2018_answers) then - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - endif ! Loop on cells to bound edge value do k = 1,N @@ -73,9 +64,9 @@ subroutine bound_edge_values( N, h, u, edge_val, h_neglect, answer_date ) slope_x_h = 0.0 if (use_2018_answers) then - sigma_l = 2.0 * ( u(k) - u(km1) ) / ( h(k) + hNeglect ) - sigma_c = 2.0 * ( u(kp1) - u(km1) ) / ( h(km1) + 2.0*h(k) + h(kp1) + hNeglect ) - sigma_r = 2.0 * ( u(kp1) - u(k) ) / ( h(k) + hNeglect ) + sigma_l = 2.0 * ( u(k) - u(km1) ) / ( h(k) + h_neglect ) + sigma_c = 2.0 * ( u(kp1) - u(km1) ) / ( h(km1) + 2.0*h(k) + h(kp1) + h_neglect ) + sigma_r = 2.0 * ( u(kp1) - u(k) ) / ( h(k) + h_neglect ) ! The limiter is used in the local coordinate system to each cell, so for convenience store ! the slope times a half grid spacing. (See White and Adcroft JCP 2008 Eqs 19 and 20) @@ -225,7 +216,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index !! is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -248,16 +239,10 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) real, dimension(4) :: B ! The right hand side of the system to solve for C [A H] real, dimension(4) :: C ! The coefficients of a fit polynomial in units that vary ! with the index (j) as [A H^(j-1)] - real :: hNeglect ! A negligible thickness in the same units as h [H]. integer :: i, j logical :: use_2018_answers ! If true use older, less accurate expressions. use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) - if (use_2018_answers) then - hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect - else - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - endif ! Loop on interior cells do i = 3,N-1 @@ -270,9 +255,9 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Avoid singularities when consecutive pairs of h vanish if (h0+h1==0.0 .or. h1+h2==0.0 .or. h2+h3==0.0) then if (use_2018_answers) then - h_min = hMinFrac*max( hNeglect, h0+h1+h2+h3 ) + h_min = hMinFrac*max( h_neglect, h0+h1+h2+h3 ) else - h_min = hMinFrac*max( hNeglect, (h0+h1)+(h2+h3) ) + h_min = hMinFrac*max( h_neglect, (h0+h1)+(h2+h3) ) endif h0 = max( h_min, h(i-2) ) h1 = max( h_min, h(i-1) ) @@ -307,7 +292,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Determine first two edge values if (use_2018_answers) then - h_min = max( hNeglect, hMinFrac*sum(h(1:4)) ) + h_min = max( h_neglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 1,4 dx = max(h_min, h(i) ) @@ -322,7 +307,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) edge_val(1,1) = evaluation_polynomial( C, 4, x(1) ) edge_val(1,2) = evaluation_polynomial( C, 4, x(2) ) else ! Use expressions with less sensitivity to roundoff - do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, C) ! Set the edge values of the first cell @@ -333,7 +318,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Determine two edge values of the last cell if (use_2018_answers) then - h_min = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) + h_min = max( h_neglect, hMinFrac*sum(h(N-3:N)) ) x(1) = 0.0 do i = 1,4 @@ -351,7 +336,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, C) ! Set the last and second to last edge values @@ -384,11 +369,10 @@ subroutine edge_values_explicit_h4cw( N, h, u, edge_val, h_neglect ) real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index !! is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] ! Local variables real :: dp(N) ! Input grid layer thicknesses, but with a minimum thickness [H ~> m or kg m-2] - real :: hNeglect ! A negligible thickness in the same units as h [H] real :: da ! Difference between the unlimited scalar edge value estimates [A] real :: a6 ! Scalar field differences that are proportional to the curvature [A] real :: slk, srk ! Differences between adjacent cell averages of scalars [A] @@ -403,10 +387,8 @@ subroutine edge_values_explicit_h4cw( N, h, u, edge_val, h_neglect ) real :: h23_h122(N+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. integer :: k - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! Set the thicknesses for very thin layers to some minimum value. - do k=1,N ; dp(k) = max(h(k), hNeglect) ; enddo + do k=1,N ; dp(k) = max(h(k), h_neglect) ; enddo !compute grid metrics do k=2,N @@ -494,7 +476,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index !! is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -524,15 +506,9 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) tri_u, & ! tridiagonal system (upper diagonal) [nondim] tri_b, & ! tridiagonal system (right hand side) [A] tri_x ! tridiagonal system (solution vector) [A] - real :: hNeglect ! A negligible thickness [H] logical :: use_2018_answers ! If true use older, less accurate expressions. use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) - if (use_2018_answers) then - hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect - else - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - endif ! Loop on cells (except last one) do i = 1,N-1 @@ -542,8 +518,8 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) h1 = h(i+1) ! Avoid singularities when h0+h1=0 if (h0+h1==0.) then - h0 = hNeglect - h1 = hNeglect + h0 = h_neglect + h1 = h_neglect endif ! Auxiliary calculations @@ -562,8 +538,8 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) tri_d(i+1) = 1.0 else ! Use expressions with less sensitivity to roundoff ! Get cell widths - h0 = max(h(i), hNeglect) - h1 = max(h(i+1), hNeglect) + h0 = max(h(i), h_neglect) + h1 = max(h(i+1), h_neglect) ! The 1e-12 here attempts to balance truncation errors from the differences of ! large numbers against errors from approximating thin layers as non-vanishing. if (abs(h0) < 1.0e-12*abs(h1)) h0 = 1.0e-12*h1 @@ -587,7 +563,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Boundary conditions: set the first boundary value if (use_2018_answers) then - h_min = max( hNeglect, hMinFrac*sum(h(1:4)) ) + h_min = max( h_neglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 1,4 dx = max(h_min, h(i) ) @@ -601,7 +577,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) tri_b(1) = evaluation_polynomial( Csys, 4, x(1) ) ! Set the first edge value tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff - do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, Csys) tri_b(1) = Csys(1) ! Set the first edge value. @@ -611,7 +587,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Boundary conditions: set the last boundary value if (use_2018_answers) then - h_min = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) + h_min = max( h_neglect, hMinFrac*sum(h(N-3:N)) ) x(1) = 0.0 do i=1,4 dx = max(h_min, h(N-4+i) ) @@ -629,7 +605,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, Csys) tri_b(N+1) = Csys(1) ! Set the last edge value @@ -806,7 +782,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the !! second index is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -837,12 +813,10 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date tri_u, & ! tridiagonal system (upper diagonal) [nondim] tri_b, & ! tridiagonal system (right hand side) [A H-1] tri_x ! tridiagonal system (solution vector) [A H-1] - real :: hNeglect ! A negligible thickness [H]. real :: hNeglect3 ! hNeglect^3 [H3]. logical :: use_2018_answers ! If true use older, less accurate expressions. - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect3 = hNeglect**3 + hNeglect3 = h_neglect**3 use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) ! Loop on cells (except last one) @@ -875,8 +849,8 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date tri_b(i+1) = a * u(i) + b * u(i+1) else ! Get cell widths - h0 = max(h(i), hNeglect) - h1 = max(h(i+1), hNeglect) + h0 = max(h(i), h_neglect) + h1 = max(h(i+1), h_neglect) I_h = 1.0 / (h0 + h1) h0 = h0 * I_h ; h1 = h1 * I_h @@ -917,7 +891,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! Set the first edge slope tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff - do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, Csys) ! Set the first edge slope @@ -945,7 +919,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, Csys) @@ -980,7 +954,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the !! second index is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! ----------------------------------------------------------------------------- @@ -1021,7 +995,6 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date real :: hMin ! The minimum thickness used in these calculations [H] real :: h01, h01_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: h23, h23_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] - real :: hNeglect ! A negligible thickness [H]. real :: h1_2, h2_2 ! Squares of thicknesses [H2] real :: h1_3, h2_3 ! Cubes of thicknesses [H3] real :: h1_4, h2_4 ! Fourth powers of thicknesses [H4] @@ -1045,12 +1018,10 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date real :: h_Min_Frac = 1.0e-4 ! A minimum fractional thickness [nondim] integer :: i, k ! loop indexes - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! Loop on cells (except the first and last ones) do k = 2,N-2 ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + hMin = max(h_neglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) @@ -1091,7 +1062,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date ! Use a right-biased stencil for the second row, as described in Eq. (53) of White and Adcroft (2009). ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) + hMin = max(h_neglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) @@ -1147,7 +1118,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + hMin = max(h_neglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) @@ -1255,7 +1226,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) real, dimension(N), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index !! is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -1263,7 +1234,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) real :: hMin ! The minimum thickness used in these calculations [H] real :: h01, h01_2, h01_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: h23, h23_2, h23_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] - real :: hNeglect ! A negligible thickness [H]. real :: h1_2, h2_2, h1_3, h2_3 ! Cell widths raised to the 2nd and 3rd powers [H2] or [H3] real :: h1_4, h2_4, h1_5, h2_5 ! Cell widths raised to the 4th and 5th powers [H4] or [H5] real :: alpha, beta ! stencil coefficients [nondim] @@ -1286,12 +1256,10 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) tri_x ! trid. system (unknowns vector) [A] integer :: i, k ! loop indexes - hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! Loop on interior cells do k = 2,N-2 ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, hMinFrac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + hMin = max(h_neglect, hMinFrac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) @@ -1329,7 +1297,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) ! Use a right-biased stencil for the second row, as described in Eq. (49) of White and Adcroft (2009). ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, hMinFrac*((h(1) + h(2)) + (h(3) + h(4)))) + hMin = max(h_neglect, hMinFrac*((h(1) + h(2)) + (h(3) + h(4)))) h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) @@ -1364,7 +1332,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) ! Boundary conditions: left boundary - hMin = max( hNeglect, hMinFrac*((h(1)+h(2)) + (h(5)+h(6)) + (h(3)+h(4))) ) + hMin = max( h_neglect, hMinFrac*((h(1)+h(2)) + (h(5)+h(6)) + (h(3)+h(4))) ) x(1) = 0.0 do i = 1,6 dx = max( hMin, h(i) ) @@ -1386,7 +1354,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) ! Use a left-biased stencil for the second to last row, as described in Eq. (50) of White and Adcroft (2009). ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, hMinFrac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + hMin = max(h_neglect, hMinFrac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) @@ -1421,7 +1389,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) ! Boundary conditions: right boundary - hMin = max( hNeglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) + hMin = max( h_neglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) x(1) = 0.0 do i = 1,6 dx = max( hMin, h(N+1-i) ) diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index b3100fe8ae..6e0be9ebba 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -87,15 +87,19 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & real, dimension(n0,2), intent(inout) :: ppoly0_S !< Edge slope of polynomial [A H-1] real, dimension(n0,DEGREE_MAX+1), intent(inout) :: ppoly0_coefs !< Coefficients of polynomial [A] integer, intent(inout) :: degree !< The degree of the polynomials - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H] !! in the same units as h0. real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value calculations [H] !! in the same units as h0. ! Local variables + real :: h_neg_edge ! A negligibly small width for the purpose of edge value + ! calculations in the same units as h0 [H] logical :: extrapolate + h_neg_edge = h_neglect ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge + ! Reset piecewise polynomials ppoly0_E(:,:) = 0.0 ppoly0_S(:,:) = 0.0 @@ -117,7 +121,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_H4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) endif @@ -129,7 +133,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_IH4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) endif @@ -148,7 +152,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PPM_CW ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_explicit_h4cw( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_explicit_h4cw( n0, h0, densities, ppoly0_E, h_neg_edge ) call PPM_monotonicity( n0, densities, ppoly0_E ) call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then @@ -167,7 +171,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & @@ -185,7 +189,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PPM_IH4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & @@ -203,13 +207,13 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P3M_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_3 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & - ppoly0_coefs, h_neglect, h_neglect_edge ) + ppoly0_coefs, h_neglect, h_neg_edge ) endif else degree = DEGREE_1 @@ -223,7 +227,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P3M_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_3 - call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) @@ -243,7 +247,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PQM_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_4 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) @@ -263,7 +267,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PQM_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_4 - call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) @@ -335,7 +339,7 @@ subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, real, dimension(n0+1), intent(in) :: x0 !< Source interface positions [H] real, dimension(n1), intent(inout) :: h1 !< Output cell widths [H] real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions [H] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H] !! in the same units as h0. real, optional, intent(in) :: h_neglect_edge !< A negligibly small width diff --git a/src/ALE/remapping_attic.F90 b/src/ALE/remapping_attic.F90 index be20a27466..ab345dc53e 100644 --- a/src/ALE/remapping_attic.F90 +++ b/src/ALE/remapping_attic.F90 @@ -28,11 +28,6 @@ module remapping_attic ! outside of the range 0 to 1. #define __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ -real, parameter :: hNeglect_dflt = 1.E-30 !< A thickness [H ~> m or kg m-2] that can be - !! added to thicknesses in a denominator without - !! changing the numerical result, except where - !! a division by zero would otherwise occur. - contains !> Compare two summation estimates of positive data and judge if due to more @@ -83,7 +78,7 @@ subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & real, intent(in) :: h1(:) !< Target grid widths (size n1) [H] integer, intent(in) :: method !< Remapping scheme to use real, intent(out) :: u1(:) !< Target cell averages (size n1) [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h [H]. ! Local variables @@ -132,7 +127,7 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) [A] real, dimension(:), & optional, intent(out) :: h1 !< Target grid widths (size n1) [H] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h [H]. ! Local variables @@ -181,7 +176,7 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & ! hFlux is the positive width of the remapped volume hFlux = abs(dx1(iTarget+1)) call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & - xL, xR, hFlux, uAve, jStart, xStart ) + xL, xR, hFlux, uAve, jStart, xStart, h_neglect ) ! uAve is the average value of u, independent of sign of dx1 fluxR = dx1(iTarget+1)*uAve ! Includes sign of dx1 @@ -218,7 +213,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, !< On exit, contains index of last cell used real, intent(inout) :: xStart !< The left edge position of cell jStart [H] !< On first entry should be 0. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h [H] ! Local variables @@ -232,11 +227,8 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, ! (notionally xR - xL) which differs due to roundoff [H]. real :: x0_2, x1_2 ! Squares of normalized positions used to evaluate polynomials [nondim] real :: x0px1, x02px12 ! Sums of normalized positions and their squares [nondim] - real :: hNeglect ! A negligible thickness in the same units as h [H] real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - q = -1.E30 x0jLl = -1.E30 x0jRl = -1.E30 @@ -288,7 +280,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, uAve = 0.5 * ( ppoly0_E(jL,1) + ppoly0_E(jL,2) ) else ! WHY IS THIS NOT WRITTEN AS xi0 = ( xL - x0jLl ) / h0(jL) ---AJA - xi0 = xL / ( h0(jL) + hNeglect ) - x0jLl / ( h0(jL) + hNeglect ) + xi0 = xL / ( h0(jL) + h_neglect ) - x0jLl / ( h0(jL) + h_neglect ) select case ( method ) case ( INTEGRATION_PCM ) @@ -347,11 +339,11 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, ! ! Determine normalized coordinates #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) - xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + hNeglect ) ) ) + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + h_neglect ) ) ) + xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + h_neglect ) ) ) #else - xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) - xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) + xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) + xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) #endif hAct = h0(jL) * ( xi1 - xi0 ) @@ -403,9 +395,9 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, ! Integrate from xL up to right boundary of cell jL #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + h_neglect ) ) ) #else - xi0 = (xL - x0jLl) / ( h0(jL) + hNeglect ) + xi0 = (xL - x0jLl) / ( h0(jL) + h_neglect ) #endif xi1 = 1.0 @@ -449,9 +441,9 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, ! Integrate from left boundary of cell jR up to xR xi0 = 0.0 #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + hNeglect ) ) ) + xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + h_neglect ) ) ) #else - xi1 = (xR - x0jRl) / ( h0(jR) + hNeglect ) + xi1 = (xR - x0jRl) / ( h0(jR) + h_neglect ) #endif hAct = hAct + h0(jR) * ( xi1 - xi0 ) @@ -568,8 +560,8 @@ logical function remapping_attic_unit_tests(verbose) v = verbose answer_date = 20190101 ! 20181231 - h_neglect = hNeglect_dflt - h_neglect_edge = hNeglect_dflt ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 + h_neglect = 1.0E-30 + h_neglect_edge = h_neglect ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 write(stdout,*) '==== remapping_attic: remapping_attic_unit_tests =================' remapping_attic_unit_tests = .false. ! Normally return false diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index de58a2f3bb..7ee90d746a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -6,7 +6,7 @@ module MOM ! Infrastructure modules use MOM_array_transform, only : rotate_array, rotate_vector use MOM_debugging, only : MOM_debugging_init, hchksum, uvchksum -use MOM_debugging, only : check_redundant +use MOM_debugging, only : check_redundant, query_debugging_checks use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum use MOM_checksum_packages, only : MOM_accel_chksum, MOM_surface_chksum use MOM_coms, only : num_PEs @@ -95,6 +95,7 @@ module MOM use MOM_forcing_type, only : homogenize_forcing, homogenize_mech_forcing use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end use MOM_grid, only : set_first_direction +use MOM_harmonic_analysis, only : HA_accum_FtF, HA_accum_FtSSH, harmonic_analysis_CS 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, calc_derived_thermo, thickness_to_dz @@ -112,6 +113,7 @@ module MOM use MOM_open_boundary, only : ocean_OBC_type, OBC_registry_type use MOM_open_boundary, only : register_temp_salt_segments, update_segment_tracer_reservoirs use MOM_open_boundary, only : open_boundary_register_restarts, remap_OBC_fields +use MOM_open_boundary, only : open_boundary_setup_vert use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init use MOM_porous_barriers, only : porous_widths_layer, porous_widths_interface, porous_barriers_init use MOM_porous_barriers, only : porous_barrier_CS @@ -389,6 +391,8 @@ module MOM !< Pointer to the control structure used for the mode-split RK2 dynamics type(MOM_dyn_split_RK2b_CS), pointer :: dyn_split_RK2b_CSp => NULL() !< Pointer to the control structure used for an alternate version of the mode-split RK2 dynamics + type(harmonic_analysis_CS), pointer :: HA_CSp => NULL() + !< Pointer to the control structure for harmonic analysis type(thickness_diffuse_CS) :: thickness_diffuse_CSp !< Pointer to the control structure used for the isopycnal height diffusive transport. !! This is also common referred to as Gent-McWilliams diffusion @@ -555,6 +559,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! multiple dynamic timesteps. logical :: do_dyn ! If true, dynamics are updated with this call. logical :: do_thermo ! If true, thermodynamics and remapping may be applied with this call. + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging. logical :: nonblocking_p_surf_update ! A flag to indicate whether surface properties ! can use nonblocking halo updates logical :: cycle_start ! If true, do calculations that are only done at the start of @@ -610,6 +615,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call cpu_clock_begin(id_clock_other) if (CS%debug) then + call query_debugging_checks(do_redundant=debug_redundant) call MOM_state_chksum("Beginning of step_MOM ", u, v, h, CS%uh, CS%vh, G, GV, US) endif @@ -624,7 +630,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call rotate_mech_forcing(forces_in, turns, forces) allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=turns) call rotate_forcing(fluxes_in, fluxes, turns) else forces => forces_in @@ -745,7 +751,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%VarMix%use_variable_mixing) then call enable_averages(cycle_time, Time_start + real_to_time(US%T_to_s*cycle_time), CS%diag) - call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix) + call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, dt) call calc_depth_function(G, CS%VarMix) call disable_averaging(CS%diag) endif @@ -788,9 +794,11 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%debug) then if (cycle_start) & call MOM_state_chksum("Before steps ", u, v, h, CS%uh, CS%vh, G, GV, US) - if (cycle_start) call check_redundant("Before steps ", u, v, G, unscale=US%L_T_to_m_s) + if (cycle_start .and. debug_redundant) & + call check_redundant("Before steps ", u, v, G, unscale=US%L_T_to_m_s) if (do_dyn) call MOM_mech_forcing_chksum("Before steps", forces, G, US, haloshift=0) - if (do_dyn) call check_redundant("Before steps ", forces%taux, forces%tauy, G, & + if (do_dyn .and. debug_redundant) & + call check_redundant("Before steps ", forces%taux, forces%tauy, G, & unscale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) endif call cpu_clock_end(id_clock_other) @@ -907,6 +915,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo endif + if (associated(CS%HA_CSp)) call HA_accum_FtF(Time_Local, CS%HA_CSp) call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & dt_therm_here, bbl_time_int, CS, & @@ -1016,6 +1025,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ssh(i,j) = CS%ssh_rint(i,j)*I_wt_ssh CS%ave_ssh_ibc(i,j) = ssh(i,j) enddo ; enddo + if (associated(CS%HA_CSp)) call HA_accum_FtSSH('ssh', ssh, Time_local, G, CS%HA_CSp) if (do_dyn) then call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, forces%p_surf_SSH, & CS%calc_rho_for_sea_lev) @@ -1044,6 +1054,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! Do diagnostics that only occur at the end of a complete forcing step. if (cycle_end) then + if (showCallTree) call callTree_waypoint("Do cycle end diagnostics (step_MOM)") if (CS%rotate_index) then allocate(sfc_state_diag) call rotate_surface_state(sfc_state, sfc_state_diag, G, turns) @@ -1063,6 +1074,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) + if (CS%rotate_index) then + call deallocate_surface_state(sfc_state_diag) + endif + if (showCallTree) call callTree_waypoint("Done with end cycle diagnostics (step_MOM)") endif ! Accumulate the surface fluxes for assessing conservation @@ -1292,7 +1307,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if ((CS%thickness_diffuse .or. CS%interface_filter) .and. & .not.CS%thickness_diffuse_first) then - if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_MKS) + if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, unscale=GV%H_to_MKS) if (CS%thickness_diffuse) then call cpu_clock_begin(id_clock_thick_diff) @@ -1301,7 +1316,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) - if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, scale=GV%H_to_MKS) + if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call cpu_clock_end(id_clock_thick_diff) call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) if (showCallTree) call callTree_waypoint("finished thickness_diffuse (step_MOM)") @@ -1322,9 +1337,9 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! apply the submesoscale mixed layer restratification parameterization if (CS%mixedlayer_restrat) then if (CS%debug) then - call hchksum(h,"Pre-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h,"Pre-mixedlayer_restrat h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Pre-mixedlayer_restrat uhtr", & - CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + CS%uhtr, CS%vhtr, G%HI, haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) endif call cpu_clock_begin(id_clock_ml_restrat) call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, CS%visc%h_ML, & @@ -1332,9 +1347,9 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call cpu_clock_end(id_clock_ml_restrat) call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) if (CS%debug) then - call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Post-mixedlayer_restrat [uv]htr", & - CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + CS%uhtr, CS%vhtr, G%HI, haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) endif endif @@ -1405,15 +1420,15 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) if (CS%debug) then call cpu_clock_begin(id_clock_other) - call hchksum(h,"Pre-advection h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h,"Pre-advection h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Pre-advection uhtr", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) - if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1, scale=US%C_to_degC) - if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1, scale=US%S_to_ppt) + haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) + if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1, unscale=US%S_to_ppt) if (associated(CS%tv%frazil)) call hchksum(CS%tv%frazil, "Pre-advection frazil", G%HI, haloshift=0, & - scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (associated(CS%tv%salt_deficit)) call hchksum(CS%tv%salt_deficit, & - "Pre-advection salt deficit", G%HI, haloshift=0, scale=US%S_to_ppt*US%RZ_to_kg_m2) + "Pre-advection salt deficit", G%HI, haloshift=0, unscale=US%S_to_ppt*US%RZ_to_kg_m2) ! call MOM_thermo_chksum("Pre-advection ", CS%tv, G, US) call cpu_clock_end(id_clock_other) endif @@ -1532,6 +1547,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! velocity points [H ~> m or kg m-2] logical :: PCM_cell(SZI_(G),SZJ_(G),SZK_(GV)) ! If true, PCM remapping should be used in a cell. logical :: use_ice_shelf ! Needed for selecting the right ALE interface. + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging. logical :: showCallTree type(group_pass_type) :: pass_T_S, pass_T_S_h, pass_uv_T_S_h integer :: dynamics_stencil ! The computational stencil for the calculations @@ -1542,6 +1558,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("step_MOM_thermo(), MOM.F90") + if (CS%debug) call query_debugging_checks(do_redundant=debug_redundant) use_ice_shelf = .false. if (associated(CS%frac_shelf_h)) use_ice_shelf = .true. @@ -1588,13 +1605,14 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_thermo) if (.not.CS%adiabatic) then if (CS%debug) then - call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) - call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, unscale=US%L_T_to_m_s) + call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Pre-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) ! call MOM_state_chksum("Pre-diabatic ", u, v, h, CS%uhtr, CS%vhtr, G, GV, vel_scale=1.0) call MOM_thermo_chksum("Pre-diabatic ", tv, G, US, haloshift=0) - call check_redundant("Pre-diabatic ", u, v, G, unscale=US%L_T_to_m_s) + if (debug_redundant) & + call check_redundant("Pre-diabatic ", u, v, G, unscale=US%L_T_to_m_s) call MOM_forcing_chksum("Pre-diabatic", fluxes, G, US, haloshift=0) endif @@ -1629,9 +1647,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (CS%debug) then call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US, omit_corners=.true.) - call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) - call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1, omit_corners=.true., scale=US%S_to_ppt) - call check_redundant("Pre-ALE ", u, v, G, unscale=US%L_T_to_m_s) + call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, omit_corners=.true., unscale=US%C_to_degC) + call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1, omit_corners=.true., unscale=US%S_to_ppt) + if (debug_redundant) & + call check_redundant("Pre-ALE ", u, v, G, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_ALE) @@ -1715,9 +1734,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (CS%debug .and. CS%use_ALE_algorithm) then call MOM_state_chksum("Post-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US) - call hchksum(tv%T, "Post-ALE T", G%HI, haloshift=1, scale=US%C_to_degC) - call hchksum(tv%S, "Post-ALE S", G%HI, haloshift=1, scale=US%S_to_ppt) - call check_redundant("Post-ALE ", u, v, G, unscale=US%L_T_to_m_s) + call hchksum(tv%T, "Post-ALE T", G%HI, haloshift=1, unscale=US%C_to_degC) + call hchksum(tv%S, "Post-ALE S", G%HI, haloshift=1, unscale=US%S_to_ppt) + if (debug_redundant) & + call check_redundant("Post-ALE ", u, v, G, unscale=US%L_T_to_m_s) endif ! Whenever thickness changes let the diag manager know, target grids @@ -1729,20 +1749,21 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, dtdia) if (CS%debug) then - call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) - call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2, unscale=US%L_T_to_m_s) + call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Post-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) ! call MOM_state_chksum("Post-diabatic ", u, v, & ! h, CS%uhtr, CS%vhtr, G, GV, haloshift=1) - if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, scale=US%C_to_degC) - if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, scale=US%S_to_ppt) + if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, unscale=US%S_to_ppt) if (associated(tv%frazil)) call hchksum(tv%frazil, "Post-diabatic frazil", G%HI, haloshift=0, & - scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, & - "Post-diabatic salt deficit", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) + "Post-diabatic salt deficit", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) ! call MOM_thermo_chksum("Post-diabatic ", tv, G, US) - call check_redundant("Post-diabatic ", u, v, G, unscale=US%L_T_to_m_s) + if (debug_redundant) & + call check_redundant("Post-diabatic ", u, v, G, unscale=US%L_T_to_m_s) endif call disable_averaging(CS%diag) @@ -1760,8 +1781,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call create_group_pass(pass_T_S, tv%S, G%Domain, To_All+Omit_Corners, halo=dynamics_stencil) call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) if (CS%debug) then - if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, scale=US%C_to_degC) - if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, scale=US%S_to_ppt) + if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, unscale=US%S_to_ppt) endif ! Update derived thermodynamic quantities. @@ -1878,7 +1899,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (.not. skip_diffusion) then if (CS%VarMix%use_variable_mixing) then call pass_var(CS%h, G%Domain) - call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, dt_offline) call calc_depth_function(G, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif @@ -1905,7 +1926,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (.not. skip_diffusion) then if (CS%VarMix%use_variable_mixing) then call pass_var(CS%h, G%Domain) - call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, dt_offline) call calc_depth_function(G, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif @@ -2007,7 +2028,8 @@ end subroutine step_offline !! initializing the ocean state variables, and initializing subsidiary modules subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & - count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp, ensemble_num) + count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp, ensemble_num, & + calve_ice_shelf_bergs) type(time_type), target, intent(inout) :: Time !< model time, set in this routine 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 @@ -2030,6 +2052,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & optional, pointer :: Waves_CSp !< An optional pointer to a wave property CS integer, optional :: ensemble_num !< Ensemble index provided by the cap (instead of FMS !! ensemble manager) + logical, optional :: calve_ice_shelf_bergs !< If true, will add point iceberg calving variables to the ice + !! shelf restart ! local variables type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the metric grid use for the run type(ocean_grid_type), pointer :: G_in => NULL() ! Pointer to the input grid @@ -2043,6 +2067,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & type(MOM_restart_CS), pointer :: restart_CSp => NULL() character(len=4), parameter :: vers_num = 'v2.0' integer :: turns ! Number of grid quarter-turns + logical :: point_calving ! Initial state on the input index map real, allocatable :: u_in(:,:,:) ! Initial zonal velocities [L T-1 ~> m s-1] @@ -2288,7 +2313,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "USE_POROUS_BARRIER", CS%use_porbar, & "If true, use porous barrier to constrain the widths "//& "and face areas at the edges of the grid cells. ", & - default=.true.) ! The default should be false after tests. + default=.false.) call get_param(param_file, "MOM", "BATHYMETRY_AT_VEL", bathy_at_vel, & "If true, there are separate values for the basin depths "//& "at velocity points. Otherwise the effects of topography "//& @@ -2628,6 +2653,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif CS%HFrz = (US%Z_to_m * GV%m_to_H) * HFrz_z + ! Finish OBC configuration that depend on the vertical grid + call open_boundary_setup_vert(GV, US, OBC_in) + ! Shift from using the temporary dynamic grid type to using the final (potentially static) ! and properly rotated ocean-specific grid type and horizontal index type. if (CS%rotate_index) then @@ -2682,7 +2710,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%tv%T => CS%T ; CS%tv%S => CS%S if (CS%tv%T_is_conT) then vd_T = var_desc(name="contemp", units="Celsius", longname="Conservative Temperature", & - cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & + cmor_field_name="bigthetao", cmor_longname="Sea Water Conservative Temperature", & conversion=US%Q_to_J_kg*CS%tv%C_p) else vd_T = var_desc(name="temp", units="degC", longname="Potential Temperature", & @@ -2691,7 +2719,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif if (CS%tv%S_is_absS) then vd_S = var_desc(name="abssalt", units="g kg-1", longname="Absolute Salinity", & - cmor_field_name="so", cmor_longname="Sea Water Salinity", & + cmor_field_name="absso", cmor_longname="Sea Water Absolute Salinity", & conversion=0.001*US%S_to_ppt) else vd_S = var_desc(name="salt", units="psu", longname="Salinity", & @@ -2775,10 +2803,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%time_in_cycle = 0.0 ; CS%time_in_thermo_cycle = 0.0 !allocate porous topography variables - allocate(CS%pbv%por_face_areaU(IsdB:IedB,jsd:jed,nz)) ; CS%pbv%por_face_areaU(:,:,:) = 1.0 - allocate(CS%pbv%por_face_areaV(isd:ied,JsdB:JedB,nz)) ; CS%pbv%por_face_areaV(:,:,:) = 1.0 - allocate(CS%pbv%por_layer_widthU(IsdB:IedB,jsd:jed,nz+1)) ; CS%pbv%por_layer_widthU(:,:,:) = 1.0 - allocate(CS%pbv%por_layer_widthV(isd:ied,JsdB:JedB,nz+1)) ; CS%pbv%por_layer_widthV(:,:,:) = 1.0 + allocate(CS%pbv%por_face_areaU(IsdB:IedB,jsd:jed,nz), source=1.0) + allocate(CS%pbv%por_face_areaV(isd:ied,JsdB:JedB,nz), source=1.0) + allocate(CS%pbv%por_layer_widthU(IsdB:IedB,jsd:jed,nz+1), source=1.0) + allocate(CS%pbv%por_layer_widthV(isd:ied,JsdB:JedB,nz+1), source=1.0) ! Use the Wright equation of state by default, unless otherwise specified ! Note: this line and the following block ought to be in a separate @@ -2866,7 +2894,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif if (.not. CS%adiabatic) then - call register_diabatic_restarts(G, US, param_file, CS%int_tide_CSp, restart_CSp) + call register_diabatic_restarts(G, GV, US, param_file, CS%int_tide_CSp, restart_CSp) endif call callTree_waypoint("restart registration complete (initialize_MOM)") @@ -2903,6 +2931,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! Consider removing this later? G%ke = GV%ke + if (use_ice_shelf) then + point_calving=.false.; if (present(calve_ice_shelf_bergs)) point_calving=calve_ice_shelf_bergs + endif + if (CS%rotate_index) then G_in%ke = GV%ke @@ -2927,20 +2959,20 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! These arrays are not initialized in most solo cases, but are needed ! when using an ice shelf. Passing the ice shelf diagnostics CS from MOM ! for legacy reasons. The actual ice shelf diag CS is internal to the ice shelf - call initialize_ice_shelf(param_file, G_in, Time, ice_shelf_CSp, diag_ptr, & - Time_init, dirs%output_directory) + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, & + Time_init, dirs%output_directory, calve_ice_shelf_bergs=point_calving) allocate(frac_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(mass_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) - call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) + call ice_shelf_query(ice_shelf_CSp, G, CS%frac_shelf_h, CS%mass_shelf) ! MOM_initialize_state is using the unrotated metric call rotate_array(CS%frac_shelf_h, -turns, frac_shelf_in) call rotate_array(CS%mass_shelf, -turns, mass_shelf_in) call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & sponge_in_CSp, ALE_sponge_in_CSp, oda_incupd_in_CSp, OBC_in, Time_in, & - frac_shelf_h=frac_shelf_in, mass_shelf = mass_shelf_in) + frac_shelf_h=frac_shelf_in, mass_shelf=mass_shelf_in) else call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & @@ -2987,7 +3019,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & deallocate(frac_shelf_in,mass_shelf_in) else if (use_ice_shelf) then - call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, Time_init, dirs%output_directory) + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, Time_init, & + dirs%output_directory, calve_ice_shelf_bergs=point_calving) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) @@ -3017,7 +3050,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (use_ice_shelf .and. CS%debug) then call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, haloshift=0) - call hchksum(CS%mass_shelf, "MOM:mass_shelf", G%HI, haloshift=0,scale=US%RZ_to_kg_m2) + call hchksum(CS%mass_shelf, "MOM:mass_shelf", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) endif call cpu_clock_end(id_clock_MOM_init) @@ -3056,8 +3089,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! \todo This block exists for legacy reasons and we should phase it out of ! all examples. !### if (CS%debug) then - call uvchksum("Pre ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) - call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Pre ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) + call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, unscale=GV%H_to_MKS) endif call callTree_waypoint("Calling adjustGridForIntegrity() to remap initial conditions (initialize_MOM)") call adjustGridForIntegrity(CS%ALE_CSp, G, GV, CS%h ) @@ -3114,11 +3147,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call cpu_clock_end(id_clock_pass_init) if (CS%debug) then - call uvchksum("Post ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) - call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=2, scale=GV%H_to_MKS) + call uvchksum("Post ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) + call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=2, unscale=GV%H_to_MKS) if (use_temperature) then - call hchksum(CS%tv%T, "Post ALE adjust init cond T", G%HI, haloshift=2, scale=US%C_to_degC) - call hchksum(CS%tv%S, "Post ALE adjust init cond S", G%HI, haloshift=2, scale=US%S_to_ppt) + call hchksum(CS%tv%T, "Post ALE adjust init cond T", G%HI, haloshift=2, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Post ALE adjust init cond S", G%HI, haloshift=2, unscale=US%S_to_ppt) endif endif endif @@ -3223,13 +3256,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & allocate(eta(SZI_(G),SZJ_(G)), source=0.0) if (CS%use_alt_split) then call initialize_dyn_split_RK2b(CS%u, CS%v, CS%h, CS%tv, CS%uh, CS%vh, eta, Time, & - G, GV, US, param_file, diag, CS%dyn_split_RK2b_CSp, restart_CSp, & + G, GV, US, param_file, diag, CS%dyn_split_RK2b_CSp, CS%HA_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) else call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%tv, CS%uh, CS%vh, eta, Time, & - G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & + G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, CS%HA_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) @@ -3702,8 +3735,8 @@ subroutine extract_surface_state(CS, sfc_state_in) if (CS%rotate_index) then allocate(sfc_state) call allocate_surface_state(sfc_state, G, use_temperature, & - do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil),& - use_iceshelves=use_iceshelves) + do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil),& + use_iceshelves=use_iceshelves, sfc_state_in=sfc_state_in, turns=turns) else sfc_state => sfc_state_in endif @@ -4117,7 +4150,7 @@ subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) heat = CS%US%Q_to_J_kg*CS%tv%C_p * & global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%T, on_PE_only=on_PE_only, tmp_scale=CS%US%C_to_degC) if (present(salt)) & - salt = 1.0e-3 * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%S, on_PE_only=on_PE_only, scale=CS%US%S_to_ppt) + salt = 1.0e-3 * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%S, on_PE_only=on_PE_only, unscale=CS%US%S_to_ppt) end subroutine get_ocean_stocks @@ -4144,9 +4177,14 @@ subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, & logical, optional, intent(in) :: write_IC !< If present and true, initial conditions are being written + logical :: showCallTree + showCallTree = callTree_showQuery() + + if (showCallTree) call callTree_waypoint("About to call save_restart (step_MOM)") call save_restart(directory, time, G, CS%restart_CS, & time_stamped=time_stamped, filename=filename, GV=GV, & num_rest_files=num_rest_files, write_IC=write_IC) + if (showCallTree) call callTree_waypoint("Done with call to save_restart (step_MOM)") if (CS%use_particles) call particles_save_restart(CS%particles, CS%h, directory, time, time_stamped) end subroutine save_MOM_restart @@ -4205,7 +4243,7 @@ subroutine MOM_end(CS) 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) + DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) ; DEALLOC_(CS%eta_av_bc) ! TODO: debug_truncations deallocation diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 5fb3ade634..42e6514ab9 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -3,6 +3,7 @@ module MOM_PressureForce_FV ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe @@ -15,11 +16,12 @@ module MOM_PressureForce_FV use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_density, calculate_spec_vol, EOS_domain use MOM_density_integrals, only : int_density_dz, int_specific_vol_dp use MOM_density_integrals, only : int_density_dz_generic_plm, int_density_dz_generic_ppm use MOM_density_integrals, only : int_spec_vol_dp_generic_plm use MOM_density_integrals, only : int_density_dz_generic_pcm, int_spec_vol_dp_generic_pcm +use MOM_density_integrals, only : diagnose_mass_weight_Z, diagnose_mass_weight_p use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS implicit none ; private @@ -46,7 +48,18 @@ module MOM_PressureForce_FV 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. - logical :: useMassWghtInterp !< Use mass weighting in T/S interpolation + integer :: MassWghtInterp !< A flag indicating whether and how to use mass weighting in T/S interpolation + logical :: correction_intxpa !< If true, apply a correction to the value of intxpa at a selected + !! interface under ice, using matching at the end values along with a + !! 5-point quadrature integral of the hydrostatic pressure or height + !! changes along that interface. The selected interface is either at the + !! ocean's surface or in the interior, depending on reset_intxpa_integral. + logical :: reset_intxpa_integral !< If true and the surface displacement between adjacent cells + !! exceeds the vertical grid spacing, reset intxpa at the interface below + !! a trusted interior cell. (This often applies in ice shelf cavities.) + real :: h_nonvanished !< A minimal layer thickness that indicates that a layer is thick enough + !! to usefully reestimate the pressure integral across the interface + !! below it [H ~> m or kg m-2] logical :: use_inaccurate_pgf_rho_anom !< If true, uses the older and less accurate !! method to calculate density anomalies, as used prior to !! March 2018. @@ -62,6 +75,10 @@ module MOM_PressureForce_FV !! for the finite volume pressure gradient calculation. !! By the default (1) is for a piecewise linear method + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: use_SSH_in_Z0p !< If true, adjust the height at which the pressure used in the + !! equation of state is 0 to account for the displacement of the sea + !! surface including adjustments for atmospheric or sea-ice pressure. logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF integer :: tides_answer_date !< Recover old answers with tides in Boussinesq mode integer :: id_e_tide = -1 !< Diagnostic identifier @@ -71,6 +88,8 @@ module MOM_PressureForce_FV integer :: id_rho_pgf = -1 !< Diagnostic identifier integer :: id_rho_stanley_pgf = -1 !< Diagnostic identifier integer :: id_p_stanley = -1 !< Diagnostic identifier + integer :: id_MassWt_u = -1 !< Diagnostic identifier + integer :: id_MassWt_v = -1 !< Diagnostic identifier type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure end type PressureForce_FV_CS @@ -128,25 +147,72 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading ! specific to tides [Z ~> m]. e_sal_tide, & ! The summation of self-attraction and loading and tidal forcing [Z ~> m]. - dM, & ! The barotropic adjustment to the Montgomery potential to + dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [L2 T-2 ~> m2 s-2]. + ! interfaces [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. - real, dimension(SZIB_(G),SZJ_(G)) :: & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & intx_za ! The zonal integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. + ! interfaces, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & intx_dza ! The change in intx_za through a layer [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJB_(G)) :: & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & inty_za ! The meridional integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. + ! interfaces, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + T_top, & ! Temperature of top layer used with correction_intxpa [C ~> degC] + S_top, & ! Salinity of top layer used with correction_intxpa [S ~> ppt] + SpV_top ! Specific volume anomaly of top layer used with correction_intxpa [R-1 ~> m3 kg-1] + real, dimension(SZIB_(G),SZJ_(G)) :: & + intx_za_cor ! Correction for curvature in intx_za [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: & + inty_za_cor ! Correction for curvature in inty_za [L2 T-2 ~> m2 s-2] + + ! These variables are used with reset_intxpa_integral. The values are taken from different + ! interfaces as a function of position. + real, dimension(SZIB_(G),SZJ_(G)) :: & + T_int_W, T_int_E, & ! Temperatures on the reference interface to the east and west of a u-point [C ~> degC] + S_int_W, S_int_E, & ! Salinities on the reference interface to the east and west of a u-point [S ~> ppt] + p_int_W, p_int_E, & ! Pressures on the reference interface to the east and west of a u-point [R L2 T-2 ~> Pa] + SpV_x_W, SpV_x_E, & ! Specific volume anomalies on the reference interface to the east and west + ! of a u-point [R-1 ~> m3 kg-1] + intx_za_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [R L2 T-2 ~> Pa]. + dp_int_x, & ! The change in x in pressure along the reference interface [R L2 T-2 ~> Pa] + intx_za_cor_ri ! The correction to intx_za based on the reference interface calculations [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: & + T_int_S, T_int_N, & ! Temperatures on the reference interface to the north and south of a v-point [C ~> degC] + S_int_S, S_int_N, & ! Salinities on the reference interface to the north and south of a v-point [S ~> ppt] + p_int_S, p_int_N, & ! Pressures on the reference interface to the north and south of a v-point [R L2 T-2 ~> Pa] + SpV_y_S, SpV_y_N, & ! Specific volume anomalies on the reference interface to the north and south + ! of a v-point [R L2 T-2 ~> Pa] + inty_za_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [L2 T-2 ~> m2 s-2]. + dp_int_y, & ! The change in y in geopotenial height along the reference interface [R L2 T-2 ~> Pa] + inty_za_cor_ri ! The correction to inty_za based on the reference interface calculations [L2 T-2 ~> m2 s-2] + logical, dimension(SZIB_(G),SZJ_(G)) :: & + seek_x_cor ! If true, try to find a u-point interface that would provide a better estimate + ! of the curvature terms in the intx_pa. + logical, dimension(SZI_(G),SZJB_(G)) :: & + seek_y_cor ! If true, try to find a v-point interface that would provide a better estimate + ! of the curvature terms in the inty_pa. + + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + MassWt_u ! The fractional mass weighting at a u-point [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + MassWt_v ! The fractional mass weighting at a v-point [nondim]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). + real :: dp_sfc ! The change in surface pressure between adjacent cells [R L2 T-2 ~> Pa] real :: dp_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. @@ -156,6 +222,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: do_more_k ! If true, there are still points where a flatter interface remains to be found. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. real :: alpha_ref ! A reference specific volume [R-1 ~> m3 kg-1] that is used @@ -165,16 +232,27 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1]. real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure ! units [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]. + real :: T5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Pressures at five quadrature points for use with the equation of state [R L2 T-2 ~> Pa] + real :: SpV5(5) ! Specific volume anomalies at five quadrature points [R-1 ~> m3 kg-1] + real :: wt_R ! A weighting factor [nondim] + ! real :: oneatm ! 1 standard atmosphere of pressure in [R L2 T-2 ~> Pa] real, parameter :: C1_6 = 1.0/6.0 ! [nondim] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k + integer, dimension(2) :: EOSdom_u ! The i-computational domain for the equation of state at u-velocity points + integer, dimension(2) :: EOSdom_v ! The i-computational domain for the equation of state at v-velocity points + integer :: i, j, k, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + EOSdom_u(1) = Isq - (G%IsdB-1) ; EOSdom_u(2) = Ieq - (G%IsdB-1) + EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1) if (.not.CS%initialized) call MOM_error(FATAL, & "MOM_PressureForce_FV_nonBouss: Module must be initialized before it is used.") @@ -193,6 +271,10 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ alpha_ref = 1.0 / CS%Rho0 I_gEarth = 1.0 / GV%g_Earth + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) then + MassWt_u(:,:,:) = 0.0 ; MassWt_v(:,:,:) = 0.0 + endif + if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -244,12 +326,14 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! and temperature across each layer. The subscripts 't' and 'b' refer ! to top and bottom values within each layer (these are the only degrees ! of freedom needed to know the linear profile). - if ( use_ALE ) then - if ( CS%Recon_Scheme == 1 ) then + if ( use_ALE .and. (CS%Recon_Scheme == 1) ) then call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - elseif ( CS%Recon_Scheme == 2) then + elseif ( use_ALE .and. (CS%Recon_Scheme == 2) ) then call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - endif + elseif (CS%reset_intxpa_integral) then + do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_b(i,j,k) = tv%T(i,j,k) ; S_b(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo endif !$OMP parallel do default(shared) private(alpha_anom,dp) @@ -262,22 +346,25 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), S_t(:,:,k), S_b(:,:,k), & p(:,:,K), p(:,:,K+1), alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, & tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & - useMassWghtInterp=CS%useMassWghtInterp) + P_surf=p(:,:,1), MassWghtInterp=CS%MassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then call MOM_error(FATAL, "PressureForce_FV_nonBouss: "//& "int_spec_vol_dp_generic_ppm does not exist yet.") ! call int_spec_vol_dp_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & ! tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & ! alpha_ref, G%HI, tv%eqn_of_state, dza(:,:,k), intp_dza(:,:,k), & - ! intx_dza(:,:,k), inty_dza(:,:,k)) + ! intx_dza(:,:,k), inty_dza(:,:,k), P_surf=p(:,:,1), MassWghtInterp=CS%MassWghtInterp) endif else call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & - inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & - useMassWghtInterp=CS%useMassWghtInterp) + inty_dza(:,:,k), bathyP=p(:,:,nz+1), P_surf=p(:,:,1), dP_tiny=dp_neglect, & + MassWghtInterp=CS%MassWghtInterp) endif + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) & + call diagnose_mass_weight_p(p(:,:,K), p(:,:,K+1), p(:,:,nz+1), p(:,:,1), dp_neglect, CS%MassWghtInterp, & + G%HI, MassWt_u(:,:,k), MassWt_v(:,:,k)) else alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -305,10 +392,10 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - za(i,j) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) + za(i,j,nz+1) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) enddo do k=nz,1,-1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) + dza(i,j,k) + za(i,j,K) = za(i,j,K+1) + dza(i,j,k) enddo ; enddo enddo @@ -316,7 +403,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (CS%calculate_SAL) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & + SSH(i,j) = (za(i,j,1) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & - max(-G%bathyT(i,j)-G%Z_ref, 0.0) enddo ; enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) @@ -324,7 +411,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq) .or. (.not.CS%tides)) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) + za(i,j,1) = za(i,j,1) - GV%g_Earth * e_sal(i,j) enddo ; enddo endif endif @@ -335,7 +422,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) + za(i,j,1) = za(i,j,1) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo else ! This block recreates older answers with tides. if (.not.CS%calculate_SAL) e_sal(:,:) = 0.0 @@ -343,85 +430,362 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_sal_tide(i,j) + za(i,j,1) = za(i,j,1) - GV%g_Earth * e_sal_tide(i,j) enddo ; enddo endif endif - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. - if (use_EOS) then - !$OMP parallel do default(shared) private(rho_in_situ) - do j=Jsq,Jeq+1 - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & - tv%eqn_of_state, EOSdom) + ! Find the height anomalies at the interfaces. If there are no tides and no SAL, + ! there is no need to correct za, but omitting this changes answers at roundoff. + do k=1,nz + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j,K+1) = za(i,j,K) - dza(i,j,k) + enddo ; enddo + enddo - do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j)) - enddo - enddo + if (CS%debug) then + call hchksum(za, "Pre-correction za", G%HI, haloshift=1, unscale=US%L_T_to_m_s**2) + call hchksum(p, "Pre-correction p", G%HI, haloshift=1, unscale=US%RL2_T2_to_Pa) + endif + + ! With an ice-shelf or icebergs, this linearity condition might need to be applied + ! to a sub-surface interface. + if (CS%correction_intxpa .or. CS%reset_intxpa_integral) then + ! Determine surface temperature and salinity for use in the pressure gradient corrections + if (use_ALE .and. (CS%Recon_Scheme > 0)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_top(i,j) = T_t(i,j,1) ; S_top(i,j) = S_t(i,j,1) + enddo ; enddo else - !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j)) + T_top(i,j) = tv%T(i,j,1) ; S_top(i,j) = tv%S(i,j,1) enddo ; enddo endif -! else -! do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; dM(i,j) = 0.0 ; enddo ; enddo endif - ! This order of integrating upward and then downward again is necessary with - ! a nonlinear equation of state, so that the surface geopotentials will go - ! linearly between the values at thickness points, but the bottom - ! geopotentials will not now be linear at the sub-grid-scale. Doing this - ! ensures no motion with flat isopycnals, even with a nonlinear equation of state. - !$OMP parallel do default(shared) - do j=js,je ; do I=Isq,Ieq - intx_za(I,j) = 0.5*(za(i,j) + za(i+1,j)) - enddo ; enddo - !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do i=is,ie - inty_za(i,J) = 0.5*(za(i,j) + za(i,j+1)) - enddo ; enddo + if (CS%correction_intxpa) then + ! This version makes a 5 point quadrature correction for hydrostatic variations in surface + ! pressure under ice. + !$OMP parallel do default(shared) private(dp_sfc,T5,S5,p5,wt_R,SpV5) + do j=js,je ; do I=Isq,Ieq + intx_za_cor(I,j) = 0.0 + dp_sfc = (p(i+1,j,1) - p(i,j,1)) + ! If the changes in pressure and height anomaly were explicable by just a hydrostatic balance, + ! the implied specific volume would be SpV_implied = alpha_ref - (dza_x / dp_x) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i+1,j,1)-za(i,j,1))) > 0.0) then + T5(1) = T_top(i,j) ; T5(5) = T_top(i+1,j) + S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) + p5(1) = p(i,j,1) ; p5(5) = p(i+1,j,1) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + ! See the Boussinesq calculation of inty_pa_cor for the derivation of the following expression. + intx_za_cor(I,j) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * dp_sfc + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + endif + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + intx_za_cor(I,j) + enddo ; enddo + !$OMP parallel do default(shared) private(dp_sfc,T5,S5,p5,wt_R,SpV5) + do J=Jsq,Jeq ; do i=is,ie + inty_za_cor(i,J) = 0.0 + dp_sfc = (p(i,j+1,1) - p(i,j,1)) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i,j+1,1)-za(i,j,1))) > 0.0) then + ! The pressure/depth relationship has a positive implied specific volume. + T5(1) = T_top(i,j) ; T5(5) = T_top(i,j+1) + S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) + p5(1) = p(i,j,1) ; p5(5) = p(i,j+1,1) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + ! See the Boussinesq calculation of inty_pa_cor for the derivation of the following expression. + inty_za_cor(i,J) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * dp_sfc + endif + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + inty_za_cor(i,J) + enddo ; enddo + else + ! This order of integrating upward and then downward again is necessary with + ! a nonlinear equation of state, so that the surface geopotentials will go + ! linearly between the values at thickness points, but the bottom geopotentials + ! will not now be linear at the sub-grid-scale. Doing this ensures no motion + ! with flat isopycnals, even with a nonlinear equation of state. + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + enddo ; enddo + endif + + do k=1,nz + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j,K+1) = intx_za(I,j,K) - intx_dza(I,j,k) + enddo ; enddo + enddo do k=1,nz - ! These expressions for the acceleration have been carefully checked in - ! a set of idealized cases, and should be bug-free. !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J,K+1) = inty_za(i,J,K) - inty_dza(i,J,k) + enddo ; enddo + enddo + + if (CS%debug) then + call uvchksum("Prelim int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("Prelim int[xy]_dza", intx_dza, inty_dza, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + endif + + if (CS%reset_intxpa_integral) then + ! Having stored the pressure gradient info, we can work out where the first nonvanished layers is + ! reset intx_za there, then adjust intx_za throughout the water column. + + ! Zero out the 2-d arrays that will be set from various reference interfaces. + T_int_W(:,:) = 0.0 ; S_int_W(:,:) = 0.0 ; p_int_W(:,:) = 0.0 + T_int_E(:,:) = 0.0 ; S_int_E(:,:) = 0.0 ; p_int_E(:,:) = 0.0 + intx_za_nonlin(:,:) = 0.0 ; intx_za_cor_ri(:,:) = 0.0 ; dp_int_x(:,:) = 0.0 + do j=js,je ; do I=Isq,Ieq + seek_x_cor(I,j) = (G%mask2dCu(I,j) > 0.) + enddo ; enddo + + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + if ((p(i+1,j,2) >= p(i,j,1)) .and. (p(i,j,2) >= p(i+1,j,1))) then + ! This is the typical case in the open ocean, so use the topmost interface. + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = p(i,j,1) ; p_int_E(I,j) = p(i+1,j,1) + intx_za_nonlin(I,j) = intx_za(I,j,1) - 0.5*(za(i,j,1) + za(i+1,j,1)) + dp_int_x(I,j) = p(i+1,j,1)-p(i,j,1) + seek_x_cor(I,j) = .false. + endif + endif ; enddo ; enddo + + do k=1,nz + do_more_k = .false. + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i+1,j,k) > CS%h_nonvanished)) .and. & + (max(0., p(i,j,1)-p(i+1,j,K+1), p(i+1,j,1)-p(i,j,K+1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intxpa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) + S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) + p_int_W(I,j) = p(i,j,K+1) ; p_int_E(I,j) = p(i+1,j,K+1) + + intx_za_nonlin(I,j) = intx_za(I,j,K+1) - 0.5*(za(i,j,K+1) + za(i+1,j,K+1)) + dp_int_x(I,j) = p(i+1,j,K+1)-p(i,j,K+1) + seek_x_cor(I,j) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + if (do_more_k) then + ! There are still points where a correction is needed, so use the top interface. + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = p(i,j,1) ; p_int_E(I,j) = p(i+1,j,1) + intx_za_nonlin(I,j) = intx_za(I,j,1) - 0.5*(za(i,j,1) + za(i+1,j,1)) + dp_int_x(I,j) = p(i+1,j,1)-p(i,j,1) + seek_x_cor(I,j) = .false. + endif ; enddo ; enddo + endif + + do j=js,je + do I=Isq,Ieq + ! This expression assumes that temperature and salinity vary linearly with pressure + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point specific volume. + ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. + T5(1) = T_Int_W(I,j) ; S5(1) = S_Int_W(I,j) ; p5(1) = p_Int_W(I,j) + T5(5) = T_Int_E(I,j) ; S5(5) = S_Int_E(I,j) ; p5(5) = p_Int_E(I,j) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + intx_za_cor_ri(I,j) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * & + dp_int_x(I,j) - intx_za_nonlin(I,j) + enddo + enddo + + ! Repeat the calculations above for v-velocity points. + T_int_S(:,:) = 0.0 ; S_int_S(:,:) = 0.0 ; p_int_S(:,:) = 0.0 + T_int_N(:,:) = 0.0 ; S_int_N(:,:) = 0.0 ; p_int_N(:,:) = 0.0 + inty_za_nonlin(:,:) = 0.0 ; inty_za_cor_ri(:,:) = 0.0 ; dp_int_y(:,:) = 0.0 + do J=Jsq,Jeq ; do i=is,ie + seek_y_cor(i,J) = (G%mask2dCv(i,J) > 0.) + enddo ; enddo + + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + if ((p(i,j+1,2) >= p(i,j,1)) .and. (p(i,j,2) >= p(i,j+1,1))) then + ! This is the typical case in the open ocean, so use the topmost interface. + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = p(i,j,1) ; p_int_N(i,J) = p(i,j+1,1) + inty_za_nonlin(i,J) = inty_za(i,J,1) - 0.5*(za(i,j,1) + za(i,j+1,1)) + dp_int_y(i,J) = p(i,j+1,1) - p(i,j,1) + seek_y_cor(i,J) = .false. + endif + endif ; enddo ; enddo + + do k=1,nz + do_more_k = .false. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i,j+1,k) > CS%h_nonvanished)) .and. & + (max(0., p(i,j,1)-p(i,j+1,K+1), p(i,j+1,1)-p(i,j,K+1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intypa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) + S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) + p_int_S(i,J) = p(i,j,K+1) ; p_int_N(i,J) = p(i,j+1,K+1) + inty_za_nonlin(i,J) = inty_za(i,J,K+1) - 0.5*(za(i,j,K+1) + za(i,j+1,K+1)) + dp_int_y(i,J) = p(i,j+1,K+1) - p(i,j,K+1) + seek_y_cor(i,J) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + if (do_more_k) then + ! There are still points where a correction is needed, so use the top interface. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = p(i,j,1) ; p_int_N(i,J) = p(i,j+1,1) + inty_za_nonlin(i,J) = inty_za(i,J,1) - 0.5*(za(i,j,1) + za(i,j+1,1)) + dp_int_y(i,J) = p(i,j+1,1) - p(i,j,1) + seek_y_cor(i,J) = .false. + endif ; enddo ; enddo + endif + + do J=Jsq,Jeq + do i=is,ie + ! This expression assumes that temperature and salinity vary linearly with pressure + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point specific volume. + ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. + T5(1) = T_Int_S(i,J) ; S5(1) = S_Int_S(i,J) ; p5(1) = p_Int_S(i,J) + T5(5) = T_Int_N(i,J) ; S5(5) = S_Int_N(i,J) ; p5(5) = p_Int_N(i,J) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + inty_za_cor_ri(i,J) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * & + dp_int_y(i,J) - inty_za_nonlin(i,J) + enddo + enddo + + if (CS%debug) then + call uvchksum("Pre-reset int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("int[xy]_za_cor", intx_za_cor_ri, inty_za_cor_ri, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("int[xy]_za_nonlin", intx_za_nonlin, inty_za_nonlin, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("dp_int_[xy]", dp_int_x, dp_int_y, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, unscale=US%RL2_T2_to_Pa) + endif + + ! Correct intx_pa and inty_pa at each interface using vertically constant corrections. + do K=1,nz+1 ; do j=js,je ; do I=Isq,Ieq + intx_za(I,j,K) = intx_za(I,j,K) + intx_za_cor_ri(I,j) + enddo ; enddo ; enddo + + do K=1,nz+1 ; do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J,K) = inty_za(i,J,K) + inty_za_cor_ri(i,J) + enddo ; enddo ; enddo + + if (CS%debug) then + call uvchksum("Post-reset int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + endif + + endif ! intx_za and inty_za have now been reset to reflect the properties of an unimpeded interface. + + !$OMP parallel do default(shared) private(dp) + do k=1,nz do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dp(i,j) = H_to_RL2_T2 * h(i,j,k) - za(i,j) = za(i,j) - dza(i,j,k) enddo ; enddo - !$OMP parallel do default(shared) + + ! Find the horizontal pressure gradient accelerations. + ! These expressions for the accelerations have been carefully checked in + ! a set of idealized cases, and should be bug-free. do j=js,je ; do I=Isq,Ieq - intx_za(I,j) = intx_za(I,j) - intx_dza(I,j,k) - PFu(I,j,k) = ( ((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & - (za(i+1,j)*dp(i+1,j) + intp_dza(i+1,j,k))) + & - ((dp(i+1,j) - dp(i,j)) * intx_za(I,j) - & + PFu(I,j,k) = ( ((za(i,j,K+1)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i+1,j,K+1)*dp(i+1,j) + intp_dza(i+1,j,k))) + & + ((dp(i+1,j) - dp(i,j)) * intx_za(I,j,K+1) - & (p(i+1,j,K) - p(i,j,K)) * intx_dza(I,j,k)) ) * & (2.0*G%IdxCu(I,j) / ((dp(i,j) + dp(i+1,j)) + dp_neglect)) enddo ; enddo - !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie - inty_za(i,J) = inty_za(i,J) - inty_dza(i,J,k) - PFv(i,J,k) = (((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & - (za(i,j+1)*dp(i,j+1) + intp_dza(i,j+1,k))) + & - ((dp(i,j+1) - dp(i,j)) * inty_za(i,J) - & + PFv(i,J,k) = (((za(i,j,K+1)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i,j+1,K+1)*dp(i,j+1) + intp_dza(i,j+1,k))) + & + ((dp(i,j+1) - dp(i,j)) * inty_za(i,J,K+1) - & (p(i,j+1,K) - p(i,j,K)) * inty_dza(i,J,k))) * & (2.0*G%IdyCv(i,J) / ((dp(i,j) + dp(i,j+1)) + dp_neglect)) enddo ; enddo + enddo + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then + !$OMP parallel do default(shared) private(rho_in_situ) + do j=Jsq,Jeq+1 + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & + tv%eqn_of_state, EOSdom) - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j,1)) + enddo + enddo + else !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j,1)) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do k=1,nz do j=js,je ; do I=Isq,Ieq PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) enddo ; enddo - !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) enddo ; enddo - endif - enddo + enddo + endif if (present(pbce)) then call set_pbce_nonBouss(p, tv_tmp, G, GV, US, CS%GFS_scale, pbce) @@ -448,6 +812,8 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) + if (CS%id_MassWt_u>0) call post_data(CS%id_MassWt_u, MassWt_u, CS%diag) + if (CS%id_MassWt_v>0) call post_data(CS%id_MassWt_v, MassWt_v, CS%diag) end subroutine PressureForce_FV_nonBouss @@ -486,6 +852,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! [Z ~> m]. e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading ! specific to tides [Z ~> m]. + Z_0p, & ! The height at which the pressure used in the equation of state is 0 [Z ~> m] SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. @@ -493,21 +860,60 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & - dz_geo, & ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. - pa, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the + dz_geo ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + pa ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the ! the interface atop a layer [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & dpa, & ! The change in pressure anomaly between the top and bottom ! of a layer [R L2 T-2 ~> Pa]. intz_dpa ! The vertical integral in depth of the pressure anomaly less the ! pressure anomaly at the top of the layer [H R L2 T-2 ~> m Pa]. - real, dimension(SZIB_(G),SZJ_(G)) :: & - intx_pa, & ! The zonal integral of the pressure anomaly along the interface + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + intx_pa ! The zonal integral of the pressure anomaly along the interface ! atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & intx_dpa ! The change in intx_pa through a layer [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJB_(G)) :: & - inty_pa, & ! The meridional integral of the pressure anomaly along the + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + inty_pa ! The meridional integral of the pressure anomaly along the ! interface atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dpa ! The change in inty_pa through a layer [R L2 T-2 ~> Pa]. + real, dimension(SZIB_(G),SZJ_(G)) :: & + intx_pa_cor ! Correction for curvature in intx_pa [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)) :: & + inty_pa_cor ! Correction for curvature in inty_pa [R L2 T-2 ~> Pa] + + ! These variables are used with reset_intxpa_integral. The values are taken from different + ! interfaces as a function of position. + real, dimension(SZIB_(G),SZJ_(G)) :: & + T_int_W, T_int_E, & ! Temperatures on the reference interface to the east and west of a u-point [C ~> degC] + S_int_W, S_int_E, & ! Salinities on the reference interface to the east and west of a u-point [S ~> ppt] + p_int_W, p_int_E, & ! Pressures on the reference interface to the east and west of a u-point [R L2 T-2 ~> Pa] + rho_x_W, rho_x_E, & ! Density anomalies on the reference interface to the east and west + ! of a u-point [R ~> kg m-3] + intx_pa_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [R L2 T-2 ~> Pa]. + dgeo_x, & ! The change in x in geopotenial height along the reference interface [L2 T-2 ~> m2 s-2] + intx_pa_cor_ri ! The correction to intx_pa based on the reference interface calculations [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)) :: & + T_int_S, T_int_N, & ! Temperatures on the reference interface to the north and south of a v-point [C ~> degC] + S_int_S, S_int_N, & ! Salinities on the reference interface to the north and south of a v-point [S ~> ppt] + p_int_S, p_int_N, & ! Pressures on the reference interface to the north and south of a v-point [R L2 T-2 ~> Pa] + rho_y_S, rho_y_N, & ! Density anomalies on the reference interface to the north and south + ! of a v-point [R ~> kg m-3] + inty_pa_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [R L2 T-2 ~> Pa]. + dgeo_y, & ! The change in y in geopotenial height along the reference interface [L2 T-2 ~> m2 s-2] + inty_pa_cor_ri ! The correction to inty_pa based on the reference interface calculations [R L2 T-2 ~> Pa] + logical, dimension(SZIB_(G),SZJ_(G)) :: & + seek_x_cor ! If true, try to find a u-point interface that would provide a better estimate + ! of the curvature terms in the intx_pa. + logical, dimension(SZI_(G),SZJB_(G)) :: & + seek_y_cor ! If true, try to find a v-point interface that would provide a better estimate + ! of the curvature terms in the inty_pa. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter @@ -519,6 +925,14 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! of salinity within each layer [S ~> ppt]. T_t, T_b ! Top and bottom edge values for linear reconstructions ! of temperature within each layer [C ~> degC]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + MassWt_u ! The fractional mass weighting at a u-point [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + MassWt_v ! The fractional mass weighting at a v-point [nondim]. + real, dimension(SZI_(G),SZJ_(G)) :: & + T_top, & ! Temperature of top layer used with correction_intxpa [C ~> degC] + S_top, & ! Salinity of top layer used with correction_intxpa [S ~> ppt] + rho_top ! Density anomaly of top layer used in calculating intx_pa_cor and inty_pa_cor real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & rho_pgf, rho_stanley_pgf ! Density [R ~> kg m-3] from EOS with and without SGS T variance ! in Stanley parameterization. @@ -528,29 +942,46 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). + real :: p_surf_EOS(SZI_(G)) ! The pressure at the ocean surface determined from the surface height, + ! consistent with what is used in the density integral routines [R L2 T-2 ~> Pa] real :: p0(SZI_(G)) ! An array of zeros to use for pressure [R L2 T-2 ~> Pa]. + real :: dz_geo_sfc ! The change in surface geopotential height between adjacent cells [L2 T-2 ~> m2 s-2] + real :: GxRho ! The gravitational acceleration times density [R L2 Z-1 T-2 ~> Pa m-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m]. real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. real :: G_Rho0 ! G_Earth / Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. + real :: I_g_rho ! The inverse of the density times the gravitational acceleration [Z T2 L-2 R-1 ~> m Pa-1] real :: rho_ref ! The reference density [R ~> kg m-3]. real :: dz_neglect ! A minimal thickness [Z ~> m], like e. real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure ! units [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]. + real :: T5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Full pressures at five quadrature points for use with the equation of state [R L2 T-2 ~> Pa] + real :: pa5(5) ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at five quadrature points [R L2 T-2 ~> Pa]. + real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] + real :: wt_R ! A weighting factor [nondim] + real, parameter :: C1_6 = 1.0/6.0 ! A rational constant [nondim] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: do_more_k ! If true, there are still points where a flatter interface remains to be found. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - real, parameter :: C1_6 = 1.0/6.0 ! [nondim] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer, dimension(2) :: EOSdom_h ! The i-computational domain for the equation of state at tracer points + integer, dimension(2) :: EOSdom_u ! The i-computational domain for the equation of state at u-velocity points + integer, dimension(2) :: EOSdom_v ! The i-computational domain for the equation of state at v-velocity points integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - integer :: i, j, k + integer :: i, j, k, m, k2 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + EOSdom_u(1) = Isq - (G%IsdB-1) ; EOSdom_u(2) = Ieq - (G%IsdB-1) + EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1) if (.not.CS%initialized) call MOM_error(FATAL, & "MOM_PressureForce_FV_Bouss: Module must be initialized before it is used.") @@ -565,8 +996,13 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm dz_neglect = GV%dZ_subroundoff I_Rho0 = 1.0 / GV%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 + GxRho = GV%g_Earth * GV%Rho0 rho_ref = CS%Rho0 + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) then + MassWt_u(:,:,:) = 0.0 ; MassWt_v(:,:,:) = 0.0 + endif + if (CS%tides_answer_date>20230630) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 e(i,j,nz+1) = -G%bathyT(i,j) @@ -648,17 +1084,15 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo ; enddo if (use_EOS) then -! With a bulk mixed layer, replace the T & S of any layers that are -! lighter than the buffer layer with the properties of the buffer -! layer. These layers will be massless anyway, and it avoids any -! formal calculations with hydrostatically unstable profiles. - if (nkmb>0) then + ! With a bulk mixed layer, replace the T & S of any layers that are lighter than the buffer + ! layer with the properties of the buffer layer. These layers will be massless anyway, and + ! it avoids any formal calculations with hydrostatically unstable profiles. tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp tv_tmp%eqn_of_state => tv%eqn_of_state do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo - !$OMP parallel do default(shared) private(Rho_cv_BL) + !$OMP parallel do default(shared) private(Rho_cv_BL) do j=Jsq,Jeq+1 do k=1,nkmb ; do i=Isq,Ieq+1 tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -680,41 +1114,18 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif endif - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. - if (use_EOS) then - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 - if (use_p_atm) then - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & - tv%eqn_of_state, EOSdom) - else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & - tv%eqn_of_state, EOSdom) - endif - do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * (e(i,j,1) - G%Z_ref) - enddo - enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref) - enddo ; enddo - endif - endif - ! I have checked that rho_0 drops out and that the 1-layer case is right. RWH. - ! If regridding is activated, do a linear reconstruction of salinity ! and temperature across each layer. The subscripts 't' and 'b' refer ! to top and bottom values within each layer (these are the only degrees ! of freedom needed to know the linear profile). - if ( use_ALE ) then - if ( CS%Recon_Scheme == 1 ) then - call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - elseif ( CS%Recon_Scheme == 2 ) then - call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - endif + if ( use_ALE .and. (CS%Recon_Scheme == 1) ) then + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif ( use_ALE .and. (CS%Recon_Scheme == 2) ) then + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif (CS%reset_intxpa_integral) then + do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_b(i,j,k) = tv%T(i,j,k) ; S_b(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo endif ! Set the surface boundary conditions on pressure anomaly and its horizontal @@ -723,22 +1134,29 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p_atm(i,j) + pa(i,j,1) = GxRho*(e(i,j,1) - G%Z_ref) + p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + pa(i,j,1) = GxRho*(e(i,j,1) - G%Z_ref) + enddo ; enddo + endif + + if (CS%use_SSH_in_Z0p .and. use_p_atm) then + I_g_rho = 1.0 / (CS%rho0*GV%g_Earth) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = e(i,j,1) + p_atm(i,j) * I_g_rho + enddo ; enddo + elseif (CS%use_SSH_in_Z0p) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = e(i,j,1) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = G%Z_ref enddo ; enddo endif - !$OMP parallel do default(shared) - do j=js,je ; do I=Isq,Ieq - intx_pa(I,j) = 0.5*(pa(i,j) + pa(i+1,j)) - enddo ; enddo - !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do i=is,ie - inty_pa(i,J) = 0.5*(pa(i,j) + pa(i,j+1)) - enddo ; enddo do k=1,nz ! Calculate 4 integrals through the layer that are required in the @@ -753,76 +1171,462 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if ( CS%Recon_Scheme == 1 ) then call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa, intz_dpa, intx_dpa, inty_dpa, & - useMassWghtInterp=CS%useMassWghtInterp, & - use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=G%Z_ref) + G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & + intx_dpa(:,:,k), inty_dpa(:,:,k), & + MassWghtInterp=CS%MassWghtInterp, & + use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=Z_0p) elseif ( CS%Recon_Scheme == 2 ) then call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa, intz_dpa, intx_dpa, inty_dpa, & - useMassWghtInterp=CS%useMassWghtInterp, Z_0p=G%Z_ref) + G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & + intx_dpa(:,:,k), inty_dpa(:,:,k), & + MassWghtInterp=CS%MassWghtInterp, Z_0p=Z_0p) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp, Z_0p=G%Z_ref) + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa(:,:,k), & + intz_dpa(:,:,k), intx_dpa(:,:,k), inty_dpa(:,:,k), G%bathyT, e(:,:,1), dz_neglect, & + CS%MassWghtInterp, Z_0p=Z_0p) endif - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - intz_dpa(i,j) = intz_dpa(i,j)*GV%Z_to_H - enddo ; enddo + if (GV%Z_to_H /= 1.0) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + intz_dpa(i,j,k) = intz_dpa(i,j,k)*GV%Z_to_H + enddo ; enddo + endif + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) & + call diagnose_mass_weight_Z(e(:,:,K), e(:,:,K+1), G%bathyT, e(:,:,1), dz_neglect, CS%MassWghtInterp, & + G%HI, MassWt_u(:,:,k), MassWt_v(:,:,k)) else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz_geo(i,j) = GV%g_Earth * GV%H_to_Z*h(i,j,k) - dpa(i,j) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) - intz_dpa(i,j) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) + dpa(i,j,k) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) + intz_dpa(i,j,k) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq - intx_dpa(I,j) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j)) + intx_dpa(I,j,k) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j)) enddo ; enddo !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie - inty_dpa(i,J) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1)) + inty_dpa(i,J,k) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1)) + enddo ; enddo + endif + enddo + + ! Set the pressure anomalies at the interfaces. + do k=1,nz + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pa(i,j,K+1) = pa(i,j,K) + dpa(i,j,k) + enddo ; enddo + enddo + + if (CS%correction_intxpa .or. CS%reset_intxpa_integral) then + ! Determine surface temperature and salinity for use in the pressure gradient corrections + if (use_ALE .and. (CS%Recon_Scheme > 0)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_top(i,j) = T_t(i,j,1) ; S_top(i,j) = S_t(i,j,1) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_top(i,j) = tv%T(i,j,1) ; S_top(i,j) = tv%S(i,j,1) enddo ; enddo endif + endif + + if (CS%correction_intxpa) then + ! Determine surface density for use in the pressure gradient corrections + !$OMP parallel do default(shared) private(p_surf_EOS) + do j=Jsq,Jeq+1 + ! P_surf_EOS here is consistent with the pressure that is used in the int_density_dz routines. + do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - Z_0p(i,j)) ; enddo + call calculate_density(T_top(:,j), S_top(:,j), p_surf_EOS, rho_top(:,j), & + tv%eqn_of_state, EOSdom, rho_ref=rho_ref) + enddo + + if (CS%debug) then + call hchksum(rho_top, "intx_pa rho_top", G%HI, haloshift=1, unscale=US%R_to_kg_m3) + call hchksum(e(:,:,1), "intx_pa e(1)", G%HI, haloshift=1, unscale=US%Z_to_m) + call hchksum(pa(:,:,1), "intx_pa pa(1)", G%HI, haloshift=1, unscale=US%RL2_T2_to_Pa) + endif - ! Compute pressure gradient in x direction + ! This version attempts to correct for hydrostatic variations in surface pressure under ice. + !$OMP parallel do default(shared) private(dz_geo_sfc) + do j=js,je ; do I=Isq,Ieq + intx_pa_cor(I,j) = 0.0 + dz_geo_sfc = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) + if ((dz_geo_sfc * rho_ref - (pa(i+1,j,1)-pa(i,j,1)))*dz_geo_sfc > 0.0) then + ! The pressure/depth relationship has a positive implied density given by + ! rho_implied = rho_ref - (pa(i+1,j,1)-pa(i,j,1)) / dz_geo_sfc + if (-dz_geo_sfc * (pa(i+1,j,1)-pa(i,j,1)) > & + 0.25*((rho_top(i+1,j)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then + ! The pressure difference is at least half the size of the difference expected by hydrostatic + ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. + ! Use 5 point quadrature to calculate intxpa + T5(1) = T_top(i,j) ; T5(5) = T_top(i+1,j) + S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) + pa5(1) = pa(i,j,1) ; pa5(5) = pa(i+1,j,1) + ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. + p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p5(5) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Use a trapezoidal rule integral of the hydrostatic equation to determine the pressure + ! anomalies at 5 equally spaced points along the interface, and then use Boole's rule + ! quadrature to find the integrated correction to the integral of pressure along the interface. + ! The derivation for this expression is shown below in the y-direction version. + intx_pa_cor(I,j) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dz_geo_sfc + ! Note that (4.75 + 5.5/2) / 90 = 1/12, so this is consistent with the linear result below. + endif + endif + intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) + intx_pa_cor(I,j) + enddo ; enddo + !$OMP parallel do default(shared) private(dz_geo_sfc) + do J=Jsq,Jeq ; do i=is,ie + inty_pa_cor(i,J) = 0.0 + dz_geo_sfc = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) + if ((dz_geo_sfc * rho_ref - (pa(i,j+1,1)-pa(i,j,1)))*dz_geo_sfc > 0.0) then + ! The pressure/depth relationship has a positive implied density + if (-dz_geo_sfc * (pa(i,j+1,1)-pa(i,j,1)) > & + 0.25*((rho_top(i,j+1)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then + ! The pressure difference is at least half the size of the difference expected by hydrostatic + ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. + ! Use 5 point quadrature to calculate intypa + T5(1) = T_top(i,j) ; T5(5) = T_top(i,j+1) + S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) + pa5(1) = pa(i,j,1) ; pa5(5) = pa(i,j+1,1) + ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. + p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p5(5) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) + + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Use a trapezoidal rule integral of the hydrostatic equation to determine the pressure + ! anomalies at 5 equally spaced points along the interface, and then use Boole's rule + ! quadrature to find the integrated correction to the integral of pressure along the interface. + inty_pa_cor(i,J) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dz_geo_sfc + + ! The derivation of this correction follows: + + ! Make pressure curvature a difference from the linear fit of pressure between the two points + ! (which is equivalent to taking 4 trapezoidal rule integrals of the hydrostatic equation on + ! sub-segments), with a constant slope that is chosen so that the pressure anomalies at the + ! two ends of the segment agree with their known values. + ! d_geo_8 = 0.125*dz_geo_sfc + ! dpa_subseg = 0.25*(pa5(5)-pa5(1)) + & + ! 0.25*d_geo_8 * ((r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3))) + ! do m=2,4 + ! pa5(m) = pa5(m-1) + dpa_subseg - d_geo_8*(r5(m)+r5(m-1))) + ! enddo + + ! Explicitly finding expressions for the incremental pressures from the recursion relation above: + ! pa5(2) = 0.25*(3.*pa5(1) + pa5(5)) + 0.25*d_geo_8 * ( (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) ) + ! ! pa5(3) = 0.5*(pa5(1) + pa5(5)) + 0.25*d_geo_8 * & + ! ! ( (r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3)) + & + ! ! (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) - 4.*(r5(3)+r5(2)) ) + ! pa5(3) = 0.5*(pa5(1) + pa5(5)) + d_geo_8 * (0.5*(r5(5)-r5(1)) + (r5(4)-r5(2)) ) + ! ! pa5(4) = 0.25*(pa5(1) + 3.0*pa5(5)) + 0.25*d_geo_8 * & + ! ! (2.0*(r5(5)-r5(1)) + 4.0*(r5(4)-r5(2)) + (r5(5)+r5(1)) + & + ! ! 2.0*(r5(4)+r5(2)) + 2.0*r5(3) - 4.*(r5(4)+r5(3))) + ! pa5(4) = 0.25*(pa5(1) + 3.0*pa5(5)) + 0.25*d_geo_8 * ( (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) ) + ! ! pa5(5) = pa5(5) + 0.25*d_geo_8 * & + ! ! ( (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) + & + ! ! ((r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3))) - 4.*(r5(5)+r5(4)) ) + ! pa5(5) = pa5(5) ! As it should. + + ! From these: + ! pa5(2) + pa5(4) = (pa5(1) + pa5(5)) + 0.25*d_geo_8 * & + ! ( (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) + (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) + ! pa5(2) + pa5(4) = (pa5(1) + pa5(5)) + d_geo_8 * ( (r5(5)-r5(1)) + (r5(4)-r5(2)) ) + + ! Get the correction from the difference between the 5-point quadrature integral of pa5 and + ! its trapezoidal rule integral as: + ! inty_pa_cor(i,J) = C1_90*(7.0*(pa5(1)+pa5(5)) + 32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 0.5*(pa5(1)+pa5(5))) + ! inty_pa_cor(i,J) = C1_90*((32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 38.0*(pa5(1)+pa5(5))) + ! inty_pa_cor(i,J) = C1_90*d_geo_8 * ((32.0*( (r5(5)-r5(1)) + (r5(4)-r5(2)) ) + & + ! (6.*(r5(5)-r5(1)) + 12.0*(r5(4)-r5(2)) )) + ! inty_pa_cor(i,J) = C1_90*d_geo_8 * ( 38.0*(r5(5)-r5(1)) + 44.0*(r5(4)-r5(2)) ) + endif + endif + inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) + inty_pa_cor(i,J) + enddo ; enddo + + if (CS%debug) then + call uvchksum("int[xy]_pa_cor", intx_pa_cor, inty_pa_cor, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%RL2_T2_to_Pa) + call uvchksum("int[xy]_pa(1)", intx_pa(:,:,1), inty_pa(:,:,1), G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%RL2_T2_to_Pa) + endif + + else + ! Set the surface boundary conditions on the horizontally integrated pressure anomaly, + ! assuming that the surface pressure anomaly varies linearly in x and y. + ! If there is an ice-shelf or icebergs, this linear variation would need to be applied + ! to an interior interface. !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq - PFu(I,j,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & - (pa(i+1,j)*h(i+1,j,k) + intz_dpa(i+1,j))) + & - ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j) - & - (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j) * GV%Z_to_H)) * & - ((2.0*I_Rho0*G%IdxCu(I,j)) / & - ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) - intx_pa(I,j) = intx_pa(I,j) + intx_dpa(I,j) + intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) enddo ; enddo - ! Compute pressure gradient in y direction !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie - PFv(i,J,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & - (pa(i,j+1)*h(i,j+1,k) + intz_dpa(i,j+1))) + & - ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J) - & - (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J) * GV%Z_to_H)) * & - ((2.0*I_Rho0*G%IdyCv(i,J)) / & - ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) - inty_pa(i,J) = inty_pa(i,J) + inty_dpa(i,J) + inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) + enddo ; enddo + endif + + do k=1,nz + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_pa(I,j,K+1) = intx_pa(I,j,K) + intx_dpa(I,j,k) enddo ; enddo + enddo + do k=1,nz !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = pa(i,j) + dpa(i,j) + do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J,K+1) = inty_pa(i,J,K) + inty_dpa(i,J,k) enddo ; enddo enddo - if (CS%GFS_scale < 1.0) then + if (CS%reset_intxpa_integral) then + ! Having stored the pressure gradient info, we can work out where the first nonvanished layers is + ! reset intxpa there, then adjust intxpa throughout the water column. + + ! Zero out the 2-d arrays that will be set from various reference interfaces. + T_int_W(:,:) = 0.0 ; S_int_W(:,:) = 0.0 ; p_int_W(:,:) = 0.0 + T_int_E(:,:) = 0.0 ; S_int_E(:,:) = 0.0 ; p_int_E(:,:) = 0.0 + intx_pa_nonlin(:,:) = 0.0 ; dgeo_x(:,:) = 0.0 ; intx_pa_cor_ri(:,:) = 0.0 + do j=js,je ; do I=Isq,Ieq + seek_x_cor(I,j) = (G%mask2dCu(I,j) > 0.) + enddo ; enddo + + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + if ((e(i+1,j,2) <= e(i,j,1)) .and. (e(i,j,2) <= e(i+1,j,1))) then + ! This is a typical case in the open ocean, so use the topmost interface. + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) + intx_pa_nonlin(I,j) = intx_pa(I,j,1) - 0.5*(pa(i,j,1) + pa(i+1,j,1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) + seek_x_cor(I,j) = .false. + endif + endif ; enddo ; enddo + + do k=1,nz + do_more_k = .false. + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i+1,j,k) > CS%h_nonvanished)) .and. & + (max(0., e(i+1,j,K+1)-e(i,j,1), e(i,j,K+1)-e(i+1,j,1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intxpa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) + S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) + ! These pressures are only used for the equation of state, and are only a function of + ! height, consistent with the expressions in the int_density_dz routines. + p_int_W(I,j) = -GxRho*(e(i,j,K+1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho*(e(i+1,j,K+1) - Z_0p(i,j)) + + intx_pa_nonlin(I,j) = intx_pa(I,j,K+1) - 0.5*(pa(i,j,K+1) + pa(i+1,j,K+1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,K+1)-e(i,j,K+1)) + seek_x_cor(I,j) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + if (do_more_k) then + ! There are still points where a correction is needed, so use the top interface for lack of a better idea? + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) + intx_pa_nonlin(I,j) = intx_pa(I,j,1) - 0.5*(pa(i,j,1) + pa(i+1,j,1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) + seek_x_cor(I,j) = .false. + endif ; enddo ; enddo + endif + + do j=js,je + do I=Isq,Ieq + ! This expression assumes that temperature and salinity vary linearly with hieght + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point density anomaly. + ! This can be used without masking because dgeo_x and intx_pa_nonlin are 0 over land. + T5(1) = T_Int_W(I,j) ; S5(1) = S_Int_W(I,j) ; p5(1) = p_Int_W(I,j) + T5(5) = T_Int_E(I,j) ; S5(5) = S_Int_E(I,j) ; p5(5) = p_Int_E(I,j) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + intx_pa_cor_ri(I,j) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dgeo_x(I,j) - & + intx_pa_nonlin(I,j) + enddo + enddo + + ! Repeat the calculations above for v-velocity points. + T_int_S(:,:) = 0.0 ; S_int_S(:,:) = 0.0 ; p_int_S(:,:) = 0.0 + T_int_N(:,:) = 0.0 ; S_int_N(:,:) = 0.0 ; p_int_N(:,:) = 0.0 + inty_pa_nonlin(:,:) = 0.0 ; dgeo_y(:,:) = 0.0 ; inty_pa_cor_ri(:,:) = 0.0 + do J=Jsq,Jeq ; do i=is,ie + seek_y_cor(i,J) = (G%mask2dCv(i,J) > 0.) + enddo ; enddo + + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + if ((e(i,j+1,2) <= e(i,j,1)) .and. (e(i,j,2) <= e(i,j+1,1))) then + ! This is a typical case in the open ocean, so use the topmost interface. + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,1) - 0.5*(pa(i,j,1) + pa(i,j+1,1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) + seek_y_cor(i,J) = .false. + endif + endif ; enddo ; enddo + do k=1,nz + do_more_k = .false. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i,j+1,k) > CS%h_nonvanished)) .and. & + (max(0., e(i,j+1,K+1)-e(i,j,1), e(i,j,K+1)-e(i,j+1,1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intypa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) + S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) + ! These pressures are only used for the equation of state, and are only a function of + ! height, consistent with the expressions in the int_density_dz routines. + p_int_S(i,J) = -GxRho*(e(i,j,K+1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho*(e(i,j+1,K+1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,K+1) - 0.5*(pa(i,j,K+1) + pa(i,j+1,K+1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,K+1)-e(i,j,K+1)) + seek_y_cor(i,J) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + if (do_more_k) then + ! There are still points where a correction is needed, so use the top interface for lack of a better idea? + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,1) - 0.5*(pa(i,j,1) + pa(i,j+1,1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) + seek_y_cor(i,J) = .false. + endif ; enddo ; enddo + endif + + do J=Jsq,Jeq + do i=is,ie + ! This expression assumes that temperature and salinity vary linearly with hieght + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point density anomaly. + ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. + T5(1) = T_Int_S(i,J) ; S5(1) = S_Int_S(i,J) ; p5(1) = p_Int_S(i,J) + T5(5) = T_Int_N(i,J) ; S5(5) = S_Int_N(i,J) ; p5(5) = p_Int_N(i,J) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + inty_pa_cor_ri(i,J) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dgeo_y(i,J) - & + inty_pa_nonlin(i,J) + enddo + enddo + + ! Correct intx_pa and inty_pa at each interface using vertically constant corrections. + do K=1,nz+1 ; do j=js,je ; do I=Isq,Ieq + intx_pa(I,j,K) = intx_pa(I,j,K) + intx_pa_cor_ri(I,j) + enddo ; enddo ; enddo + + do K=1,nz+1 ; do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J,K) = inty_pa(i,J,K) + inty_pa_cor_ri(i,J) + enddo ; enddo ; enddo + endif ! intx_pa and inty_pa have now been reset to reflect the properties of an unimpeded interface. + + ! Compute pressure gradient in x direction + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = (((pa(i,j,K)*h(i,j,k) + intz_dpa(i,j,k)) - & + (pa(i+1,j,K)*h(i+1,j,k) + intz_dpa(i+1,j,k))) + & + ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j,K) - & + (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j,k) * GV%Z_to_H)) * & + ((2.0*I_Rho0*G%IdxCu(I,j)) / & + ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) + enddo ; enddo ; enddo + + ! Compute pressure gradient in y direction + !$OMP parallel do default(shared) + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = (((pa(i,j,K)*h(i,j,k) + intz_dpa(i,j,k)) - & + (pa(i,j+1,K)*h(i,j+1,k) + intz_dpa(i,j+1,k))) + & + ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J,K) - & + (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J,k) * GV%Z_to_H)) * & + ((2.0*I_Rho0*G%IdyCv(i,J)) / & + ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) + enddo ; enddo ; enddo + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + if (use_p_atm) then + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & + tv%eqn_of_state, EOSdom) + else + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & + tv%eqn_of_state, EOSdom) + endif + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * (e(i,j,1) - G%Z_ref) + enddo + enddo + else !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do k=1,nz do j=js,je ; do I=Isq,Ieq PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) enddo ; enddo - !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) enddo ; enddo @@ -911,6 +1715,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) + if (CS%id_MassWt_u>0) call post_data(CS%id_MassWt_u, MassWt_u, CS%diag) + if (CS%id_MassWt_v>0) call post_data(CS%id_MassWt_v, MassWt_v, CS%diag) if (CS%id_rho_pgf>0) call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) if (CS%id_rho_stanley_pgf>0) call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) @@ -934,6 +1740,11 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] integer :: default_answer_date ! Global answer date + logical :: use_temperature ! If true, temperature and salinity are used as state variables. + logical :: use_EOS ! If true, density calculated from T & S using an equation of state. + logical :: useMassWghtInterp ! If true, use near-bottom mass weighting for T and S + logical :: MassWghtInterpTop ! If true, use near-surface mass weighting for T and S under ice shelves + logical :: MassWghtInterp_NonBous_bug ! If true, use a buggy mass weighting when non-Boussinesq ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -948,6 +1759,9 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, mdl = "MOM_PressureForce_FV" call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true., do_not_log=.true.) call get_param(param_file, mdl, "RHO_PGF_REF", CS%Rho0, & "The reference density that is subtracted off when calculating pressure "//& "gradient forces. Its inverse is subtracted off of specific volumes when "//& @@ -967,13 +1781,61 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, endif call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & "If true, calculate self-attraction and loading.", default=CS%tides) + + call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & + "If true, Temperature and salinity are used as state variables.", & + default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "USE_EOS", use_EOS, & + "If true, density is calculated from temperature and "//& + "salinity with an equation of state. If USE_EOS is "//& + "true, ENABLE_THERMODYNAMICS must be true as well.", & + default=use_temperature, do_not_log=.true.) + + call get_param(param_file, mdl, "SSH_IN_EOS_PRESSURE_FOR_PGF", CS%use_SSH_in_Z0p, & + "If true, include contributions from the sea surface height in the height-based "//& + "pressure used in the equation of state calculations for the Boussinesq pressure "//& + "gradient forces, including adjustments for atmospheric or sea-ice pressure.", & + default=.false., do_not_log=.not.GV%Boussinesq) + call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) - call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & - "If true, use mass weighting when interpolating T/S for "//& - "integrals near the bathymetry in FV pressure gradient "//& - "calculations.", default=.false.) + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", useMassWghtInterp, & + "If true, use mass weighting when interpolating T/S for integrals "//& + "near the bathymetry in FV pressure gradient calculations.", & + default=.false.) + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP", MassWghtInterpTop, & + "If true and MASS_WEIGHT_IN_PRESSURE_GRADIENT is true, use mass weighting when "//& + "interpolating T/S for integrals near the top of the water column in FV "//& + "pressure gradient calculations. ", & + default=.false.) !### Change Default to MASS_WEIGHT_IN_PRESSURE_GRADIENT? + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PGF_NONBOUS_BUG", MassWghtInterp_NonBous_bug, & + "If true, use a masking bug in non-Boussinesq calculations with mass weighting "//& + "when interpolating T/S for integrals near the bathymetry in FV pressure "//& + "gradient calculations.", & + default=.false., do_not_log=(GV%Boussinesq .or. (.not.useMassWghtInterp))) + CS%MassWghtInterp = 0 + if (useMassWghtInterp) & + CS%MassWghtInterp = ibset(CS%MassWghtInterp, 0) ! Same as CS%MassWghtInterp + 1 + if (MassWghtInterpTop) & + CS%MassWghtInterp = ibset(CS%MassWghtInterp, 1) ! Same as CS%MassWghtInterp + 2 + if ((.not.GV%Boussinesq) .and. MassWghtInterp_NonBous_bug) & + CS%MassWghtInterp = ibset(CS%MassWghtInterp, 3) ! Same as CS%MassWghtInterp + 8 + + call get_param(param_file, mdl, "CORRECTION_INTXPA", CS%correction_intxpa, & + "If true, use a correction for surface pressure curvature in intx_pa.", & + default=.false., do_not_log=.not.use_EOS) + call get_param(param_file, mdl, "RESET_INTXPA_INTEGRAL", CS%reset_intxpa_integral, & + "If true, reset INTXPA to match pressures at first nonvanished cell. "//& + "Includes pressure correction.", default=.false., do_not_log=.not.use_EOS) + if (.not.use_EOS) then ! These options do nothing without an equation of state. + CS%correction_intxpa = .false. + CS%reset_intxpa_integral = .false. + endif + call get_param(param_file, mdl, "RESET_INTXPA_H_NONVANISHED", CS%h_nonvanished, & + "A minimal layer thickness that indicates that a layer is thick enough to usefully "//& + "reestimate the pressure integral across the interface below.", & + default=1.0e-6, units="m", scale=GV%m_to_H, do_not_log=.not.CS%reset_intxpa_integral) call get_param(param_file, mdl, "USE_INACCURATE_PGF_RHO_ANOM", CS%use_inaccurate_pgf_rho_anom, & "If true, use a form of the PGF that uses the reference density "//& "in an inaccurate way. This is not recommended.", default=.false.) @@ -1024,6 +1886,11 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, 'Read-in tidal self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif + CS%id_MassWt_u = register_diag_field('ocean_model', 'MassWt_u', diag%axesCuL, Time, & + 'The fractional mass weighting at u-point PGF calculations', 'nondim') + CS%id_MassWt_v = register_diag_field('ocean_model', 'MassWt_v', diag%axesCvL, Time, & + 'The fractional mass weighting at v-point PGF calculations', 'nondim') + CS%GFS_scale = 1.0 if (GV%g_prime(1) /= GV%g_Earth) CS%GFS_scale = GV%g_prime(1) / GV%g_Earth diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 0d30cd8671..af2beca1fb 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -16,8 +16,9 @@ module MOM_barotropic use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, only : HA_accum_FtSSH, harmonic_analysis_CS use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher, NORTH_FACE, EAST_FACE use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, open_boundary_query use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type @@ -25,6 +26,8 @@ module MOM_barotropic use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_self_attr_load, only : scalar_SAL_sensitivity use MOM_self_attr_load, only : SAL_CS +use MOM_streaming_filter, only : Filt_register, Filt_accum, Filter_CS +use MOM_tidal_forcing, only : tidal_frequency use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : BT_cont_type, alloc_bt_cont_type @@ -247,6 +250,10 @@ module MOM_barotropic logical :: linearized_BT_PV !< If true, the PV and interface thicknesses used !! in the barotropic Coriolis calculation is time !! invariant and linearized. + logical :: use_filter_m2 !< If true, apply streaming band-pass filter for detecting + !! instantaneous tidal signals. + logical :: use_filter_k1 !< If true, apply streaming band-pass filter for detecting + !! instantaneous tidal signals. logical :: use_wide_halos !< If true, use wide halos and march in during the !! barotropic time stepping for efficiency. logical :: clip_velocity !< If true, limit any velocity components that are @@ -282,12 +289,18 @@ module MOM_barotropic logical :: tidal_sal_flather !< Apply adjustment to external gravity wave speed !! consistent with tidal self-attraction and loading !! used within the barotropic solver + logical :: wt_uv_bug = .true. !< If true, recover a bug that wt_[uv] that is not normalized. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate !! the timing of diagnostic output. type(MOM_domain_type), pointer :: BT_Domain => NULL() !< Barotropic MOM domain type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type type(SAL_CS), pointer :: SAL_CSp => NULL() !< Control structure for SAL + type(harmonic_analysis_CS), pointer :: HA_CSp => NULL() !< Control structure for harmonic analysis + type(Filter_CS) :: Filt_CS_um2, & !< Control structures for the M2 streaming filter + Filt_CS_vm2, & !< Control structures for the M2 streaming filter + Filt_CS_uk1, & !< Control structures for the K1 streaming filter + Filt_CS_vk1 !< Control structures for the K1 streaming filter logical :: module_is_initialized = .false. !< If true, module has been initialized integer :: isdw !< The lower i-memory limit for the wide halo arrays. @@ -506,6 +519,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: wt_v(SZI_(G),SZJB_(G),SZK_(GV)) ! normalized weights to ! be used in calculating barotropic velocities, possibly with ! sums less than one due to viscous losses [nondim] + real :: Iwt_u_tot(SZIB_(G),SZJ_(G)) ! Iwt_u_tot and Iwt_v_tot are the + real :: Iwt_v_tot(SZI_(G),SZJB_(G)) ! inverses of wt_u and wt_v vertical integrals, + ! used to normalize wt_u and wt_v [nondim] real, dimension(SZIB_(G),SZJ_(G)) :: & av_rem_u, & ! The weighted average of visc_rem_u [nondim] tmp_u, & ! A temporary array at u points [L T-2 ~> m s-2] or [nondim] @@ -592,6 +608,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, DCor_v, & ! An averaged total thickness at v points [H ~> m or kg m-2]. Datv ! Basin depth at v-velocity grid points times the x-grid ! spacing [H L ~> m2 or kg m-1]. + real, dimension(:,:), pointer :: um2, uk1, vm2, vk1 + ! M2 and K1 velocities from the output of streaming filters [m s-1] real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & eta, & ! The barotropic free surface height anomaly or column mass ! anomaly [H ~> m or kg m-2] @@ -1052,6 +1070,30 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, wt_v(i,J,k) = CS%frhatv(i,J,k) * visc_rem enddo ; enddo ; enddo + if (.not. CS%wt_uv_bug) then + do j=js,je ; do I=is-1,ie ; Iwt_u_tot(I,j) = wt_u(I,j,1) ; enddo ; enddo + do k=2,nz ; do j=js,je ; do I=is-1,ie + Iwt_u_tot(I,j) = Iwt_u_tot(I,j) + wt_u(I,j,k) + enddo ; enddo ; enddo + do j=js,je ; do I=is-1,ie + if (abs(Iwt_u_tot(I,j)) > 0.0 ) Iwt_u_tot(I,j) = G%mask2dCu(I,j) / Iwt_u_tot(I,j) + enddo ; enddo + do k=1,nz ; do j=js,je ; do I=is-1,ie + wt_u(I,j,k) = wt_u(I,j,k) * Iwt_u_tot(I,j) + enddo ; enddo ; enddo + + do J=js-1,je ; do i=is,ie ; Iwt_v_tot(i,J) = wt_v(i,J,1) ; enddo ; enddo + do k=2,nz ; do J=js-1,je ; do i=is,ie + Iwt_v_tot(i,J) = Iwt_v_tot(i,J) + wt_v(i,J,k) + enddo ; enddo ; enddo + do J=js-1,je ; do i=is,ie + if (abs(Iwt_v_tot(i,J)) > 0.0 ) Iwt_v_tot(i,J) = G%mask2dCv(i,J) / Iwt_v_tot(i,J) + enddo ; enddo + do k=1,nz ; do J=js-1,je ; do i=is,ie + wt_v(i,J,k) = wt_v(i,J,k) * Iwt_v_tot(i,J) + enddo ; enddo ; enddo + endif + ! Use u_Cor and v_Cor as the reference values for the Coriolis terms, ! including the viscous remnant. !$OMP parallel do default(shared) @@ -1556,6 +1598,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ; enddo ; enddo endif + ! Here is an example of how the filter equations are time stepped to determine the M2 and K1 velocities. + ! The filters are initialized and registered in subroutine barotropic_init. + if (CS%use_filter_m2) then + call Filt_accum(ubt, um2, CS%Time, US, CS%Filt_CS_um2) + call Filt_accum(vbt, vm2, CS%Time, US, CS%Filt_CS_vm2) + endif + if (CS%use_filter_k1) then + call Filt_accum(ubt, uk1, CS%Time, US, CS%Filt_CS_uk1) + call Filt_accum(vbt, vk1, CS%Time, US, CS%Filt_CS_vk1) + endif + ! Zero out the arrays for various time-averaged quantities. if (find_etaav) then !$OMP do @@ -1697,23 +1750,23 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug) then call uvchksum("BT [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=0, & - scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) - call uvchksum("BT Initial [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=0, scale=US%L_T_to_m_s) - call hchksum(eta, "BT Initial eta", CS%debug_BT_HI, haloshift=0, scale=GV%H_to_MKS) + unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + call uvchksum("BT Initial [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=0, unscale=US%L_T_to_m_s) + call hchksum(eta, "BT Initial eta", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS) call uvchksum("BT BT_force_[uv]", BT_force_u, BT_force_v, & - CS%debug_BT_HI, haloshift=0, scale=US%L_T2_to_m_s2) + CS%debug_BT_HI, haloshift=0, unscale=US%L_T2_to_m_s2) if (interp_eta_PF) then - call hchksum(eta_PF_1, "BT eta_PF_1",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) - call hchksum(d_eta_PF, "BT d_eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) + call hchksum(eta_PF_1, "BT eta_PF_1",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS) + call hchksum(d_eta_PF, "BT d_eta_PF",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS) else - call hchksum(eta_PF, "BT eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) - call hchksum(eta_PF_in, "BT eta_PF_in",G%HI,haloshift=0, scale=GV%H_to_MKS) + call hchksum(eta_PF, "BT eta_PF",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eta_PF_in, "BT eta_PF_in",G%HI,haloshift=0, unscale=GV%H_to_MKS) endif - call uvchksum("BT Cor_ref_[uv]", Cor_ref_u, Cor_ref_v, CS%debug_BT_HI, haloshift=0, scale=US%L_T2_to_m_s2) + call uvchksum("BT Cor_ref_[uv]", Cor_ref_u, Cor_ref_v, CS%debug_BT_HI, haloshift=0, unscale=US%L_T2_to_m_s2) call uvchksum("BT [uv]hbt0", uhbt0, vhbt0, CS%debug_BT_HI, haloshift=0, & - scale=US%L_to_m**2*US%s_to_T*GV%H_to_m) + unscale=US%L_to_m**2*US%s_to_T*GV%H_to_m) if (.not. use_BT_cont) then - call uvchksum("BT Dat[uv]", Datu, Datv, CS%debug_BT_HI, haloshift=1, scale=US%L_to_m*GV%H_to_m) + call uvchksum("BT Dat[uv]", Datu, Datv, CS%debug_BT_HI, haloshift=1, unscale=US%L_to_m*GV%H_to_m) endif call uvchksum("BT wt_[uv]", wt_u, wt_v, G%HI, haloshift=0, & symmetric=.true., omit_corners=.true., scalar_pair=.true.) @@ -1721,9 +1774,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, symmetric=.true., omit_corners=.true., scalar_pair=.true.) call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & symmetric=.true., omit_corners=.true., scalar_pair=.true.) - call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, scale=US%L_T2_to_m_s2) + call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, unscale=US%L_T2_to_m_s2) call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, & - scale=GV%m_to_H, scalar_pair=.true.) + unscale=GV%m_to_H, scalar_pair=.true.) call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, & haloshift=1, scalar_pair=.true.) endif @@ -2296,22 +2349,22 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug_bt) then write(mesg,'("BT vel update ",I4)') n call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s*US%s_to_T) + unscale=US%L_T_to_m_s*US%s_to_T) call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s*US%s_to_T) + unscale=US%L_T_to_m_s*US%s_to_T) call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s*US%s_to_T) + unscale=US%L_T_to_m_s*US%s_to_T) call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, & haloshift=iev-ie, scalar_pair=.true.) call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s) + unscale=US%L_T_to_m_s) call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s) + unscale=US%L_T_to_m_s) call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) if (integral_BT_cont) & call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_to_m**2*GV%H_to_m) + unscale=US%L_to_m**2*GV%H_to_m) endif if (find_PF) then @@ -2398,10 +2451,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug_bt) then call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) if (integral_BT_cont) & call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & - haloshift=iev-ie, scale=US%L_to_m**2*GV%H_to_m) + haloshift=iev-ie, unscale=US%L_to_m**2*GV%H_to_m) endif if (integral_BT_cont) then @@ -2435,15 +2488,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug_bt) then write(mesg,'("BT step ",I4)') n call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s) - call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, scale=GV%H_to_MKS) + unscale=US%L_T_to_m_s) + call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, unscale=GV%H_to_MKS) endif if (GV%Boussinesq) then do j=js,je ; do i=is,ie if ((eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), & - -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%isd_global, j + G%jsd_global + -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset if (err_count < 2) & call MOM_error(WARNING, "btstep: eta has dropped below bathyT: "//trim(mesg), all_print=.true.) err_count = err_count + 1 @@ -2505,7 +2558,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. !GOMP parallel do default(shared) - do J=js-1,je ; do I=is,ie + do J=js-1,je ; do i=is,ie l_seg = OBC%segnum_v(i,J) if (l_seg == OBC_NONE) cycle @@ -2523,6 +2576,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, eta_out(i,j) = eta_wtd(i,j) * I_sum_wt_eta enddo ; enddo + ! Accumulator is updated at the end of every baroclinic time step. + ! Harmonic analysis will not be performed of a field that is not registered. + if (associated(CS%HA_CSp) .and. find_etaav) then + call HA_accum_FtSSH('ubt', ubt, CS%Time, G, CS%HA_CSp) + call HA_accum_FtSSH('vbt', vbt, CS%Time, G, CS%HA_CSp) + endif + if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post) if (G%nonblocking_updates) then @@ -2919,8 +2979,8 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) CS%dtbt_max = dtbt_max if (CS%debug) then - call chksum0(CS%dtbt, "End set_dtbt dtbt", scale=US%T_to_s) - call chksum0(CS%dtbt_max, "End set_dtbt dtbt_max", scale=US%T_to_s) + call chksum0(CS%dtbt, "End set_dtbt dtbt", unscale=US%T_to_s) + call chksum0(CS%dtbt_max, "End set_dtbt dtbt_max", unscale=US%T_to_s) endif end subroutine set_dtbt @@ -3670,9 +3730,9 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) scalar_pair=.true.) if (present(h_u) .and. present(h_v)) & call uvchksum("btcalc h_[uv]", h_u, h_v, G%HI, haloshift=0, & - symmetric=.true., omit_corners=.true., scale=GV%H_to_MKS, & + symmetric=.true., omit_corners=.true., unscale=GV%H_to_MKS, & scalar_pair=.true.) - call hchksum(h, "btcalc h",G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h, "btcalc h",G%HI, haloshift=1, unscale=GV%H_to_MKS) endif end subroutine btcalc @@ -4374,7 +4434,7 @@ end subroutine bt_mass_source !! barotropic calculation and initializes any barotropic fields that have not !! already been initialized. subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, & - restart_CS, calc_dtbt, BT_cont, SAL_CSp) + restart_CS, calc_dtbt, BT_cont, SAL_CSp, HA_CSp) 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 @@ -4400,6 +4460,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, !! barotropic flow. type(SAL_CS), target, optional :: SAL_CSp !< A pointer to the control structure of the !! SAL module. + type(harmonic_analysis_CS), target, optional :: HA_CSp !< A pointer to the control structure of the + !! harmonic analysis module ! This include declares and sets the variable "version". # include "version_variable.h" @@ -4420,6 +4482,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! drag piston velocity. character(len=80) :: wave_drag_var ! The wave drag piston velocity variable ! name in wave_drag_file. + character(len=80) :: wave_drag_u ! The wave drag piston velocity variable + ! name in wave_drag_file. + character(len=80) :: wave_drag_v ! The wave drag piston velocity variable + ! name in wave_drag_file. real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. real :: Z_to_H ! A local unit conversion factor [H Z-1 ~> nondim or kg m-3] @@ -4436,6 +4502,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: use_BT_cont_type logical :: use_tides + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -4580,12 +4647,18 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "BAROTROPIC_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions in the barotropic solver. "//& "Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values uuse more efficient or general expressions.", & + "while higher values use more efficient or general expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "VISC_REM_BT_WEIGHT_BUG", CS%wt_uv_bug, & + "If true, recover a bug in barotropic solver that uses an unnormalized weight "//& + "function for vertical averages of baroclinic velocity and forcing. Default "//& + "of this flag is set by VISC_REM_BUG.", default=visc_rem_bug) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + if (use_tides .and. present(HA_CSp)) CS%HA_CSp => HA_CSp call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & "If true, calculate self-attraction and loading.", default=use_tides) det_de = 0.0 @@ -4654,8 +4727,17 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "piston velocities.", default="", do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "BT_WAVE_DRAG_VAR", wave_drag_var, & "The name of the variable in BT_WAVE_DRAG_FILE with the "//& - "barotropic linear wave drag piston velocities at h points.", & + "barotropic linear wave drag piston velocities at h points. "//& + "It will not be used if both BT_WAVE_DRAG_U and BT_WAVE_DRAG_V are defined.", & default="rH", do_not_log=.not.CS%linear_wave_drag) + call get_param(param_file, mdl, "BT_WAVE_DRAG_U", wave_drag_u, & + "The name of the variable in BT_WAVE_DRAG_FILE with the "//& + "barotropic linear wave drag piston velocities at u points.", & + default="", do_not_log=.not.CS%linear_wave_drag) + call get_param(param_file, mdl, "BT_WAVE_DRAG_V", wave_drag_v, & + "The name of the variable in BT_WAVE_DRAG_FILE with the "//& + "barotropic linear wave drag piston velocities at v points.", & + default="", do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "BT_WAVE_DRAG_SCALE", wave_drag_scale, & "A scaling factor for the barotropic linear wave drag "//& "piston velocities.", default=1.0, units="nondim", & @@ -4875,19 +4957,32 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, wave_drag_file = trim(slasher(inputdir))//trim(wave_drag_file) call log_param(param_file, mdl, "INPUTDIR/BT_WAVE_DRAG_FILE", wave_drag_file) - allocate(lin_drag_h(isd:ied,jsd:jed), source=0.0) + if (len_trim(wave_drag_u) > 0 .and. len_trim(wave_drag_v) > 0) then + call MOM_read_data(wave_drag_file, wave_drag_u, CS%lin_drag_u, G%Domain, & + position=EAST_FACE, scale=GV%m_to_H*US%T_to_s) + call pass_var(CS%lin_drag_u, G%Domain) + CS%lin_drag_u(:,:) = wave_drag_scale * CS%lin_drag_u(:,:) - call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=GV%m_to_H*US%T_to_s) - call pass_var(lin_drag_h, G%Domain) - do j=js,je ; do I=is-1,ie - CS%lin_drag_u(I,j) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%lin_drag_v(i,J) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) - enddo ; enddo - deallocate(lin_drag_h) - endif - endif + call MOM_read_data(wave_drag_file, wave_drag_v, CS%lin_drag_v, G%Domain, & + position=NORTH_FACE, scale=GV%m_to_H*US%T_to_s) + call pass_var(CS%lin_drag_v, G%Domain) + CS%lin_drag_v(:,:) = wave_drag_scale * CS%lin_drag_v(:,:) + + else + allocate(lin_drag_h(isd:ied,jsd:jed), source=0.0) + + call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=GV%m_to_H*US%T_to_s) + call pass_var(lin_drag_h, G%Domain) + do j=js,je ; do I=is-1,ie + CS%lin_drag_u(I,j) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + CS%lin_drag_v(i,J) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) + enddo ; enddo + deallocate(lin_drag_h) + endif ! len_trim(wave_drag_u) > 0 .and. len_trim(wave_drag_v) > 0 + endif ! len_trim(wave_drag_file) > 0 + endif ! CS%linear_wave_drag CS%dtbt_fraction = 0.98 ; if (dtbt_input < 0.0) CS%dtbt_fraction = -dtbt_input @@ -5174,6 +5269,8 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) type(vardesc) :: vd(3) character(len=40) :: mdl = "MOM_barotropic" ! This module's name. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: am2, ak1 !< Bandwidth parameters of the M2 and K1 streaming filters [nondim] + real :: om2, ok1 !< Target frequencies of the M2 and K1 streaming filters [T-1 ~> s-1] isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB @@ -5186,6 +5283,33 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) "sum(u dh_dt) while also correcting for truncation errors.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "STREAMING_FILTER_M2", CS%use_filter_m2, & + "If true, turn on streaming band-pass filter for detecting "//& + "instantaneous tidal signals.", default=.false.) + call get_param(param_file, mdl, "STREAMING_FILTER_K1", CS%use_filter_k1, & + "If true, turn on streaming band-pass filter for detecting "//& + "instantaneous tidal signals.", default=.false.) + call get_param(param_file, mdl, "FILTER_ALPHA_M2", am2, & + "Bandwidth parameter of the streaming filter targeting the M2 frequency. "//& + "Must be positive. To turn off filtering, set FILTER_ALPHA_M2 <= 0.0.", & + default=0.0, units="nondim", do_not_log=.not.CS%use_filter_m2) + call get_param(param_file, mdl, "FILTER_ALPHA_K1", ak1, & + "Bandwidth parameter of the streaming filter targeting the K1 frequency. "//& + "Must be positive. To turn off filtering, set FILTER_ALPHA_K1 <= 0.0.", & + default=0.0, units="nondim", do_not_log=.not.CS%use_filter_k1) + call get_param(param_file, mdl, "TIDE_M2_FREQ", om2, & + "Frequency of the M2 tidal constituent. "//& + "This is only used if TIDES and TIDE_M2"// & + " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and M2"// & + " is in OBC_TIDE_CONSTITUENTS.", units="s-1", default=tidal_frequency("M2"), & + scale=US%T_to_s, do_not_log=.true.) + call get_param(param_file, mdl, "TIDE_K1_FREQ", ok1, & + "Frequency of the K1 tidal constituent. "//& + "This is only used if TIDES and TIDE_K1"// & + " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and K1"// & + " is in OBC_TIDE_CONSTITUENTS.", units="s-1", default=tidal_frequency("K1"), & + scale=US%T_to_s, do_not_log=.true.) + ALLOC_(CS%ubtav(IsdB:IedB,jsd:jed)) ; CS%ubtav(:,:) = 0.0 ALLOC_(CS%vbtav(isd:ied,JsdB:JedB)) ; CS%vbtav(:,:) = 0.0 if (CS%gradual_BT_ICs) then @@ -5214,6 +5338,24 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & longname="Barotropic timestep", units="seconds", conversion=US%T_to_s) + ! Initialize and register streaming filters + if (CS%use_filter_m2) then + if (am2 > 0.0 .and. om2 > 0.0) then + call Filt_register(am2, om2, 'u', HI, CS%Filt_CS_um2) + call Filt_register(am2, om2, 'v', HI, CS%Filt_CS_vm2) + else + CS%use_filter_m2 = .false. + endif + endif + if (CS%use_filter_k1) then + if (ak1 > 0.0 .and. ok1 > 0.0) then + call Filt_register(ak1, ok1, 'u', HI, CS%Filt_CS_uk1) + call Filt_register(ak1, ok1, 'v', HI, CS%Filt_CS_vk1) + else + CS%use_filter_k1 = .false. + endif + endif + end subroutine register_barotropic_restarts !> \namespace mom_barotropic diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index b892742cf3..6b89323475 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -75,10 +75,10 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, sy scale_vel = US%L_T_to_m_s ; if (present(vel_scale)) scale_vel = vel_scale call uvchksum(mesg//" [uv]", u, v, G%HI, haloshift=hs, symmetric=sym, & - omit_corners=omit_corners, scale=scale_vel) - call hchksum(h, mesg//" h", G%HI, haloshift=hs, omit_corners=omit_corners, scale=GV%H_to_MKS) + omit_corners=omit_corners, unscale=scale_vel) + call hchksum(h, mesg//" h", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=GV%H_to_MKS) call uvchksum(mesg//" [uv]h", uh, vh, G%HI, haloshift=hs, symmetric=sym, & - omit_corners=omit_corners, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + omit_corners=omit_corners, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) end subroutine MOM_state_chksum_5arg ! ============================================================================= @@ -110,8 +110,8 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric, hs = 1 ; if (present(haloshift)) hs = haloshift sym = .false. ; if (present(symmetric)) sym = symmetric call uvchksum(mesg//" u", u, v, G%HI, haloshift=hs, symmetric=sym, & - omit_corners=omit_corners, scale=US%L_T_to_m_s) - call hchksum(h, mesg//" h",G%HI, haloshift=hs, omit_corners=omit_corners, scale=GV%H_to_MKS) + omit_corners=omit_corners, unscale=US%L_T_to_m_s) + call hchksum(h, mesg//" h",G%HI, haloshift=hs, omit_corners=omit_corners, unscale=GV%H_to_MKS) end subroutine MOM_state_chksum_3arg ! ============================================================================= @@ -130,22 +130,22 @@ subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift, omit_corners) hs=1 ; if (present(haloshift)) hs=haloshift if (associated(tv%T)) & - call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%C_to_degC) + call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%C_to_degC) if (associated(tv%S)) & - call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%S_to_ppt) + call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%S_to_ppt) if (associated(tv%frazil)) & call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, omit_corners=omit_corners, & - scale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) + unscale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) if (associated(tv%salt_deficit)) & call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, omit_corners=omit_corners, & - scale=US%S_to_ppt*US%RZ_to_kg_m2) + unscale=US%S_to_ppt*US%RZ_to_kg_m2) if (associated(tv%varT)) & - call hchksum(tv%varT, mesg//" varT", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%C_to_degC**2) + call hchksum(tv%varT, mesg//" varT", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%C_to_degC**2) if (associated(tv%varS)) & - call hchksum(tv%varS, mesg//" varS", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%S_to_ppt**2) + call hchksum(tv%varS, mesg//" varS", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%S_to_ppt**2) if (associated(tv%covarTS)) & call hchksum(tv%covarTS, mesg//" covarTS", G%HI, haloshift=hs, omit_corners=omit_corners, & - scale=US%S_to_ppt*US%C_to_degC) + unscale=US%S_to_ppt*US%C_to_degC) end subroutine MOM_thermo_chksum @@ -170,26 +170,26 @@ subroutine MOM_surface_chksum(mesg, sfc_state, G, US, haloshift, symmetric) hs = 0 ; if (present(haloshift)) hs = haloshift if (allocated(sfc_state%SST)) call hchksum(sfc_state%SST, mesg//" SST", G%HI, haloshift=hs, & - scale=US%C_to_degC) + unscale=US%C_to_degC) if (allocated(sfc_state%SSS)) call hchksum(sfc_state%SSS, mesg//" SSS", G%HI, haloshift=hs, & - scale=US%S_to_ppt) + unscale=US%S_to_ppt) if (allocated(sfc_state%sea_lev)) call hchksum(sfc_state%sea_lev, mesg//" sea_lev", G%HI, & - haloshift=hs, scale=US%Z_to_m) + haloshift=hs, unscale=US%Z_to_m) if (allocated(sfc_state%Hml)) call hchksum(sfc_state%Hml, mesg//" Hml", G%HI, haloshift=hs, & - scale=US%Z_to_m) + unscale=US%Z_to_m) if (allocated(sfc_state%u) .and. allocated(sfc_state%v)) & call uvchksum(mesg//" SSU", sfc_state%u, sfc_state%v, G%HI, haloshift=hs, symmetric=sym, & - scale=US%L_T_to_m_s) + unscale=US%L_T_to_m_s) if (allocated(sfc_state%frazil)) call hchksum(sfc_state%frazil, mesg//" frazil", G%HI, & - haloshift=hs, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + haloshift=hs, unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (allocated(sfc_state%melt_potential)) call hchksum(sfc_state%melt_potential, mesg//" melt_potential", & - G%HI, haloshift=hs, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + G%HI, haloshift=hs, unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (allocated(sfc_state%ocean_mass)) call hchksum(sfc_state%ocean_mass, mesg//" ocean_mass", & - G%HI, haloshift=hs, scale=US%RZ_to_kg_m2) + G%HI, haloshift=hs, unscale=US%RZ_to_kg_m2) if (allocated(sfc_state%ocean_heat)) call hchksum(sfc_state%ocean_heat, mesg//" ocean_heat", & - G%HI, haloshift=hs, scale=US%C_to_degC*US%RZ_to_kg_m2) + G%HI, haloshift=hs, unscale=US%C_to_degC*US%RZ_to_kg_m2) if (allocated(sfc_state%ocean_salt)) call hchksum(sfc_state%ocean_salt, mesg//" ocean_salt", & - G%HI, haloshift=hs, scale=US%S_to_ppt*US%RZ_to_kg_m2) + G%HI, haloshift=hs, unscale=US%S_to_ppt*US%RZ_to_kg_m2) end subroutine MOM_surface_chksum @@ -240,14 +240,14 @@ subroutine MOM_accel_chksum(mesg, CAu, CAv, PFu, PFv, diffu, diffv, G, GV, US, p ! Note that for the chksum calls to be useful for reproducing across PE ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. - call uvchksum(mesg//" CA[uv]", CAu, CAv, G%HI, haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) - call uvchksum(mesg//" PF[uv]", PFu, PFv, G%HI, haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) - call uvchksum(mesg//" diffu", diffu, diffv, G%HI,haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) + call uvchksum(mesg//" CA[uv]", CAu, CAv, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T2_to_m_s2) + call uvchksum(mesg//" PF[uv]", PFu, PFv, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T2_to_m_s2) + call uvchksum(mesg//" diffu", diffu, diffv, G%HI,haloshift=0, symmetric=sym, unscale=US%L_T2_to_m_s2) if (present(pbce)) & - call hchksum(pbce, mesg//" pbce",G%HI,haloshift=0, scale=GV%m_to_H*US%L_T_to_m_s**2) + call hchksum(pbce, mesg//" pbce",G%HI,haloshift=0, unscale=GV%m_to_H*US%L_T_to_m_s**2) if (present(u_accel_bt) .and. present(v_accel_bt)) & call uvchksum(mesg//" [uv]_accel_bt", u_accel_bt, v_accel_bt, G%HI,haloshift=0, symmetric=sym, & - scale=US%L_T2_to_m_s2) + unscale=US%L_T2_to_m_s2) end subroutine MOM_accel_chksum ! ============================================================================= diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 13181902ec..db60b2f0e4 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -1698,10 +1698,10 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then if (present(v_cor)) then call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) else call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) endif endif ; endif @@ -2750,7 +2750,6 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) "If true, use the marginal face areas from the continuity "//& "solver for use as the weights in the barotropic solver. "//& "Otherwise use the transport averaged areas.", default=.true.) - CS%diag => diag id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index bf6b2f6fef..90994dd073 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -31,6 +31,7 @@ module MOM_density_integrals public int_spec_vol_dp_generic_plm public avg_specific_vol public find_depth_of_pressure_in_cell +public diagnose_mass_weight_Z, diagnose_mass_weight_p contains @@ -39,7 +40,7 @@ module MOM_density_integrals !! required for calculating the finite-volume form pressure accelerations in a !! Boussinesq model. subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -76,17 +77,20 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] if (EOS_quadrature(EOS)) then call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p=Z_0p) else call analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif end subroutine int_density_dz @@ -95,8 +99,8 @@ end subroutine int_density_dz !> Calculates (by numerical quadrature) integrals of pressure anomalies across layers, which !! are required for calculating the finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, use_inaccurate_form, Z_0p) + EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, use_inaccurate_form, Z_0p) type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature of the layer [C ~> degC] @@ -133,12 +137,15 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of !! density anomalies, as was used prior to March 2018. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] @@ -156,7 +163,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: dz ! The layer thickness [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A pressure-thickness below topography [Z ~> m] real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] @@ -166,7 +173,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] real :: intz(5) ! The gravitational acceleration times the integrals of density ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] - logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: do_massWeight ! Indicates whether to do mass weighting near bathymetry + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface logical :: use_rho_ref ! Pass rho_ref to the equation of state for more accurate calculation ! of density anomalies. integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state @@ -183,20 +191,29 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif use_rho_ref = .true. if (present(use_inaccurate_form)) then if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "bathyT must be present if useMassWghtInterp is present and true.") - if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + if (do_massWeight .and. .not.present(bathyT)) call MOM_error(FATAL, & + "int_density_dz_generic: bathyT must be present if near-bottom mass weighting is in use.") + if (top_massWeight .and. .not.present(SSH)) call MOM_error(FATAL, & + "int_density_dz_generic: SSH must be present if near-surface mass weighting is in use.") + if ((do_massWeight .or. top_massWeight) .and. .not.present(dz_neglect)) call MOM_error(FATAL, & + "int_density_dz_generic: dz_neglect must be present if mass weighting is in use.") + endif ! Set the loop ranges for equation of state calculations at various points. EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(Ieq-Isq+2) @@ -208,7 +225,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dz = z_t(i,j) - z_b(i,j) do n=1,5 T5(i*5+n) = T(i,j) ; S5(i*5+n) = S(i,j) - p5(i*5+n) = -GxRho*((z_t(i,j) - z0pres) - 0.25*real(n-1)*dz) + p5(i*5+n) = -GxRho*((z_t(i,j) - z0pres(i,j)) - 0.25*real(n-1)*dz) enddo enddo @@ -239,6 +256,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect @@ -259,7 +278,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & pos = i*15+(m-2)*5 T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i+1,j)) S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i+1,j)) - p15(pos+1) = -GxRho*(((wt_L*z_t(i,j)) + (wt_R*z_t(i+1,j))) - z0pres) + p15(pos+1) = -GxRho * ((wt_L*(z_t(i,j)-z0pres(i,j))) + (wt_R*(z_t(i+1,j)-z0pres(i+1,j)))) do n=2,5 T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) @@ -305,6 +324,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect @@ -325,7 +346,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & pos = i*15+(m-2)*5 T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i,j+1)) S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i,j+1)) - p15(pos+1) = -GxRho*(((wt_L*z_t(i,j)) + (wt_R*z_t(i,j+1))) - z0pres) + p15(pos+1) = -GxRho * ((wt_L*(z_t(i,j)-z0pres(i,j))) + (wt_R*(z_t(i,j+1)-z0pres(i,j+1)))) do n=2,5 T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) @@ -368,7 +389,7 @@ end subroutine int_density_dz_generic_pcm !! T and S are linear profiles. subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, use_stanley_eos, dpa, & - intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, & + intz_dpa, intx_dpa, inty_dpa, MassWghtInterp, & use_inaccurate_form, Z_0p) integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays @@ -409,11 +430,12 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the layer !! divided by the y grid spacing [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of !! density anomalies, as was used prior to March 2018. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -460,11 +482,13 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] - real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: massWeightToggle ! A non-dimensional toggle factor for near-bottom mass weighting (0 or 1) [nondim] + real :: TopWeightToggle ! A non-dimensional toggle factor for near-surface mass weighting (0 or 1) [nondim] real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [C ~> degC] real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [S ~> ppt] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A topographically limited thickness weight [Z ~> m] + real :: hWghtTop ! An ice draft limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] logical :: use_rho_ref ! Pass rho_ref to the equation of state for more accurate calculation @@ -479,15 +503,20 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p - massWeightToggle = 0. - if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightToggle = 1. + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 endif - use_rho_ref = .true. - if (present(use_inaccurate_form)) then - if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form + massWeightToggle = 0. ; TopWeightToggle = 0. + if (present(MassWghtInterp)) then + if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. + if (BTEST(MassWghtInterp, 1)) TopWeightToggle = 1. endif + use_rho_ref = .true. + if (present(use_inaccurate_form)) use_rho_ref = .not. use_inaccurate_form use_varT = .false. !ensure initialized use_covarTS = .false. @@ -520,7 +549,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & do i = Isq,Ieq+1 dz(i) = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(i*5+n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz(i)) + p5(i*5+n) = -GxRho*((e(i,j,K) - z0pres(i,j)) - 0.25*real(n-1)*dz(i)) ! Salinity and temperature points are linearly interpolated S5(i*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * S_b(i,j,k) T5(i*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * T_b(i,j,k) @@ -580,6 +609,17 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + ! CY: The below code just uses top interface, which may be bad in high res open ocean + ! We want something like if (pa(i+1,k+1) 0.) then hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff @@ -613,7 +653,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+1) = (w_left*Stl) + (w_right*Str) S15(pos+5) = (w_left*Sbl) + (w_right*Sbr) - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - z0pres) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i+1,j,K)-z0pres(i+1,j)))) ! Pressure do n=2,5 @@ -676,6 +716,17 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + ! CY: The below code just uses top interface, which may be bad in high res open ocean + ! We want something like if (pa(j+1,k+1) 0.) then hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff @@ -709,7 +760,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+1) = (w_left*Stl) + (w_right*Str) S15(pos+5) = (w_left*Sbl) + (w_right*Sbr) - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - z0pres) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i,j+1,K)-z0pres(i,j+1)))) ! Pressure do n=2,5 @@ -773,7 +824,7 @@ end subroutine int_density_dz_generic_plm !! are parabolic profiles subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, use_stanley_eos, & - dpa, intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, MassWghtInterp, Z_0p) integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -813,9 +864,10 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the layer !! divided by the y grid spacing [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -860,15 +912,17 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & real :: dz ! Layer thicknesses at tracer points [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] - real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: massWeightToggle ! A non-dimensional toggle factor for near-bottom mass weighting (0 or 1) [nondim] + real :: TopWeightToggle ! A non-dimensional toggle factor for near-surface mass weighting (0 or 1) [nondim] real :: Ttl, Tbl, Tml, Ttr, Tbr, Tmr ! Temperatures at the velocity cell corners [C ~> degC] real :: Stl, Sbl, Sml, Str, Sbr, Smr ! Salinities at the velocity cell corners [S ~> ppt] real :: s6 ! PPM curvature coefficient for S [S ~> ppt] real :: t6 ! PPM curvature coefficient for T [C ~> degC] real :: T_top, T_mn, T_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of T [C ~> degC] real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S [S ~> ppt] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A topographically limited thickness weight [Z ~> m] + real :: hWghtTop ! A surface displacement limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state @@ -882,10 +936,17 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p - massWeightToggle = 0. - if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightToggle = 1. + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif + massWeightToggle = 0. ; TopWeightToggle = 0. + if (present(MassWghtInterp)) then + if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. + if (BTEST(MassWghtInterp, 1)) TopWeightToggle = 1. endif ! In event PPM calculation is bypassed with use_PPM=False @@ -929,7 +990,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & endif dz = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(I*5+n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz) + p5(I*5+n) = -GxRho*((e(i,j,K) - z0pres(i,j)) - 0.25*real(n-1)*dz) ! Salinity and temperature points are reconstructed with PPM S5(I*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) T5(I*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) @@ -973,6 +1034,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + hWghtTop = TopWeightToggle * & + max(0., e(i+1,j,K+1)-e(i,j,1), e(i,j,K+1)-e(i+1,j,1)) + hWght = max(hWght, hWghtTop) if (hWght > 0.) then hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff @@ -1016,7 +1080,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & dz_x(m,i) = (w_left*(e(i,j,K) - e(i,j,K+1))) + (w_right*(e(i+1,j,K) - e(i+1,j,K+1))) pos = i*15+(m-2)*5 - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - z0pres) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i+1,j,K)-z0pres(i+1,j)))) do n=2,5 p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) enddo @@ -1078,6 +1142,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + hWghtTop = TopWeightToggle * & + max(0., e(i,j+1,K+1)-e(i,j,1), e(i,j,K+1)-e(i,j+1,1)) + hWght = max(hWght, hWghtTop) if (hWght > 0.) then hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff @@ -1121,7 +1188,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & dz_y(m,i) = (w_left*(e(i,j,K) - e(i,j,K+1))) + (w_right*(e(i,j+1,K) - e(i,j+1,K+1))) pos = i*15+(m-2)*5 - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - z0pres) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i,j+1,K)-z0pres(i,j+1)))) do n=2,5 p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) enddo @@ -1179,7 +1246,7 @@ end subroutine int_density_dz_generic_ppm !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -1213,19 +1280,21 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals if (EOS_quadrature(EOS)) then call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) else call analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) endif end subroutine int_specific_vol_dp @@ -1237,7 +1306,7 @@ end subroutine int_specific_vol_dp !! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, dza, & intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, useMassWghtInterp) + bathyP, P_surf, dP_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature of the layer [C ~> degC] @@ -1272,10 +1341,12 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with - !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + !! the same units as p_t [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -1308,6 +1379,8 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state @@ -1320,14 +1393,18 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "bathyP must be present if useMassWghtInterp is present and true.") - if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + if (do_massWeight .and. .not.present(bathyP)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_pcm: bathyP must be present if near-bottom mass weighting is in use.") + if (top_massWeight .and. .not.present(P_surf)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_pcm: P_surf must be present if near-surface mass weighting is in use.") + if ((do_massWeight .or. top_massWeight) .and. .not.present(dP_neglect)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_pcm: dP_neglect must be present if mass weighting is in use.") + endif ! Set the loop ranges for equation of state calculations at various points. EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(ieh-ish+1) @@ -1366,8 +1443,13 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -1421,8 +1503,13 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect @@ -1478,7 +1565,7 @@ end subroutine int_spec_vol_dp_generic_pcm !! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & dP_neglect, bathyP, HI, EOS, US, dza, & - intp_dza, intx_dza, inty_dza, useMassWghtInterp) + intp_dza, intx_dza, inty_dza, P_surf, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_t !< Potential temperature at the top of the layer [C ~> degC] @@ -1518,8 +1605,10 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, optional, intent(inout) :: inty_dza !< The integral in y of the difference between !! the geopotential anomaly at the top and bottom of the layer divided !! by the y grid spacing [L2 T-2 ~> m2 s-2] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -1556,6 +1645,8 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! 5 sub-column locations [L2 T-2 ~> m2 s-2] real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state @@ -1563,8 +1654,14 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - do_massWeight = .false. - if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + if (top_massWeight .and. .not.present(P_surf)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_plm: P_surf must be present if near-surface mass weighting is in use.") + endif do n = 1, 5 ! Note that these are reversed from int_density_dz. wt_t(n) = 0.25 * real(n-1) @@ -1607,8 +1704,13 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! weighting. Note: To work in terrain following coordinates we could ! offset this distance by the layer thickness to replicate other models. hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -1668,8 +1770,13 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! hydrostatic consistency. For large hWght we bias the interpolation ! of T,S along the top and bottom integrals, like thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect @@ -1726,6 +1833,172 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, end subroutine int_spec_vol_dp_generic_plm +!> Diagnose the fractional mass weighting in a layer that might be used with a Boussinesq calculation. +subroutine diagnose_mass_weight_Z(z_t, z_b, bathyT, SSH, dz_neglect, MassWghtInterp, HI, & + MassWt_u, MassWt_v) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: SSH !< The sea surface height [Z ~> m] + real, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + integer, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, dimension(SZIB_(HI),SZJ_(HI)), & + intent(inout) :: MassWt_u !< The fractional mass weighting at u-points [nondim] + real, dimension(SZI_(HI),SZJB_(HI)), & + intent(inout) :: MassWt_v !< The fractional mass weighting at v-points [nondim] + + ! Local variables + real :: hWght ! A pressure-thickness below topography [Z ~> m] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] + logical :: do_massWeight ! Indicates whether to do mass weighting near bathymetry + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + integer :: Isq, Ieq, Jsq, Jeq, i, j + + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + + ! Calculate MassWt_u + do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_u(I,j) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_u(I,j) = 0.0 + endif + enddo ; enddo + + ! Calculate MassWt_v + do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_v(i,J) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_v(i,J) = 0.0 + endif + enddo ; enddo + +end subroutine diagnose_mass_weight_Z + + +!> Diagnose the fractional mass weighting in a layer that might be used with a non-Boussinesq calculation. +subroutine diagnose_mass_weight_p(p_t, p_b, bathyP, P_surf, dP_neglect, MassWghtInterp, HI, & + MassWt_u, MassWt_v) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] + real, intent(in) :: dP_neglect ! Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] + integer, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, dimension(SZIB_(HI),SZJ_(HI)), & + intent(inout) :: MassWt_u !< The fractional mass weighting at u-points [nondim] + real, dimension(SZI_(HI),SZJB_(HI)), & + intent(inout) :: MassWt_v !< The fractional mass weighting at v-points [nondim] + + ! Local variables + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting + integer :: Isq, Ieq, Jsq, Jeq, i, j + + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + + ! Calculate MassWt_u + do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_u(I,j) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_u(I,j) = 0.0 + endif + enddo ; enddo + + ! Calculate MassWt_v + do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_v(i,J) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_v(i,J) = 0.0 + endif + enddo ; enddo + +end subroutine diagnose_mass_weight_p + !> Find the depth at which the reconstructed pressure matches P_tgt subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & rho_ref, G_e, EOS, US, P_b, z_out, z_tol) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index b315916ec5..f602b65240 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -22,7 +22,7 @@ module MOM_dynamics_split_RK2 use MOM_domains, only : To_North, To_East, Omit_Corners 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, pass_vector -use MOM_debugging, only : hchksum, uvchksum +use MOM_debugging, only : hchksum, uvchksum, query_debugging_checks use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint @@ -47,6 +47,7 @@ module MOM_dynamics_split_RK2 use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, only : harmonic_analysis_CS use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS use MOM_hor_visc, only : hor_visc_init, hor_visc_end @@ -177,6 +178,8 @@ module MOM_dynamics_split_RK2 logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + logical :: visc_rem_dt_bug = .true. !< If true, recover a bug that uses dt_pred rather than dt for vertvisc_rem + !! at the end of predictor. !>@{ Diagnostic IDs integer :: id_uold = -1, id_vold = -1 @@ -241,6 +244,8 @@ module MOM_dynamics_split_RK2 type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the harmonic analysis control structure + type(harmonic_analysis_CS) :: HA_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() @@ -386,6 +391,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] logical :: dyn_p_surf + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating ! the barotropic accelerations. @@ -418,9 +424,12 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) if (CS%debug) then + call query_debugging_checks(do_redundant=debug_redundant) call MOM_state_chksum("Start predictor ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym) - call check_redundant("Start predictor u ", u_inst, v_inst, G, unscale=US%L_T_to_m_s) - call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Start predictor u ", u_inst, v_inst, G, unscale=US%L_T_to_m_s) + call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) @@ -477,7 +486,6 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass - ! PFu = d/dx M(h,T,S) ! pbce = dM/deta if (CS%begw == 0.0) call enable_averages(dt, Time_local, CS%diag) @@ -561,10 +569,12 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + if (debug_redundant) then + call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif endif call cpu_clock_begin(id_clock_vertvisc) @@ -583,7 +593,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call disable_averaging(CS%diag) if (CS%debug) then - call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) endif call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) @@ -667,24 +677,26 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call cpu_clock_end(id_clock_mom_update) if (CS%debug) then - call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & - symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) ! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1, & symmetric=sym) - call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) - call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif ! up <- up + dt_pred d/dz visc d/dz up ! u_av <- u_av + dt_pred d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) if (CS%debug) then - call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) endif if (CS%fpmix) then @@ -725,7 +737,11 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + if (CS%visc_rem_dt_bug) then + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + else + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + endif call cpu_clock_end(id_clock_vertvisc) call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) @@ -739,8 +755,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! hp = h + dt * div . uh call cpu_clock_begin(id_clock_continuity) call continuity(up, vp, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & - CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, & - u_av, v_av, BT_cont=CS%BT_cont) + uhbt=CS%uhbt, vhbt=CS%vhbt, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, & + u_cor=u_av, v_cor=v_av, BT_cont=CS%BT_cont) call cpu_clock_end(id_clock_continuity) if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)") @@ -749,12 +765,12 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f if (associated(CS%OBC)) then if (CS%debug) & - call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt_pred) if (CS%debug) & - call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) ! These should be done with a pass that excludes uh & vh. ! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) @@ -832,16 +848,18 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f if (CS%debug) then call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, scale=GV%H_to_MKS) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, unscale=GV%H_to_MKS) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) - call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) - call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, & MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, & OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & ADp=CS%ADp, hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) @@ -877,10 +895,12 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + if (debug_redundant) then + call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif endif ! u_accel_bt = layer accelerations due to barotropic solver @@ -904,7 +924,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call cpu_clock_end(id_clock_btstep) if (showCallTree) call callTree_leave("btstep()") - if (CS%debug) then + if (CS%debug .and. debug_redundant) then call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2) endif @@ -924,10 +944,10 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call cpu_clock_end(id_clock_mom_update) if (CS%debug) then - call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & - symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & @@ -994,7 +1014,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. call cpu_clock_begin(id_clock_continuity) call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & - CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av) + uhbt=CS%uhbt, vhbt=CS%vhbt, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, & + u_cor=u_av, v_cor=v_av) call cpu_clock_end(id_clock_continuity) call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass) ! Whenever thickness changes let the diag manager know, target grids @@ -1152,8 +1173,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f if (CS%debug) then call MOM_state_chksum("Corrector ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, unscale=GV%H_to_MKS) ! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US) endif @@ -1290,7 +1311,7 @@ end subroutine remap_dyn_split_RK2_aux_vars !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, param_file, & - diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & + diag, CS, HA_CSp, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil) @@ -1313,6 +1334,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p type(param_file_type), intent(in) :: param_file !< parameter file for parsing type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + type(harmonic_analysis_CS), pointer :: HA_CSp !< A pointer to the control structure of the + !! harmonic analysis module type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure real, intent(in) :: dt !< time step [T ~> s] type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for @@ -1347,6 +1370,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p type(group_pass_type) :: pass_av_h_uvh logical :: debug_truncations logical :: read_uv, read_h2 + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB @@ -1414,6 +1438,16 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & + "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& + "for in two places. This parameter controls the defaults of two individual "//& + "flags, VISC_REM_TIMESTEP_BUG in MOM_dynamics_split_RK2(b) and "//& + "VISC_REM_BT_WEIGHT_BUG in MOM_barotropic.", default=.true.) + call get_param(param_file, mdl, "VISC_REM_TIMESTEP_BUG", CS%visc_rem_dt_bug, & + "If true, recover a bug that uses dt_pred rather than dt in "//& + "vertvisc_remnant() at the end of predictor stage for the following "//& + "continuity() and btstep() calls in the corrector step. Default of this flag "//& + "is set by VISC_REM_BUG", default=visc_rem_bug) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) @@ -1473,7 +1507,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) - if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%use_tides) then + call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp, CS%HA_CSp) + HA_CSp => CS%HA_CSp + else + HA_CSp => NULL() + endif call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) @@ -1507,11 +1546,11 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & - CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, CS%SAL_CSp) + CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, CS%SAL_CSp, HA_CSp) if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & .not. query_initialized(CS%diffv, "diffv", restart_CS)) then - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & + call horizontal_viscosity(u, v, h, uh, vh, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) call set_initialized(CS%diffu, "diffu", restart_CS) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index e55e2e3f96..87e46795b5 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -24,7 +24,7 @@ module MOM_dynamics_split_RK2b use MOM_domains, only : To_North, To_East, Omit_Corners 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, pass_vector -use MOM_debugging, only : hchksum, uvchksum +use MOM_debugging, only : hchksum, uvchksum, query_debugging_checks use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint @@ -49,6 +49,7 @@ module MOM_dynamics_split_RK2b use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, only : harmonic_analysis_CS use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS use MOM_hor_visc, only : hor_visc_init, hor_visc_end @@ -174,6 +175,8 @@ module MOM_dynamics_split_RK2b logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + logical :: visc_rem_dt_bug = .true. !< If true, recover a bug that uses dt_pred rather than dt for vertvisc_rem + !! at the end of predictor. !>@{ Diagnostic IDs ! integer :: id_uold = -1, id_vold = -1 @@ -238,6 +241,8 @@ module MOM_dynamics_split_RK2b type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the harmonic analysis control structure + type(harmonic_analysis_CS) :: HA_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() @@ -385,6 +390,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] logical :: dyn_p_surf + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating ! the barotropic accelerations. @@ -414,9 +420,12 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) if (CS%debug) then + call query_debugging_checks(do_redundant=debug_redundant) call MOM_state_chksum("Start predictor ", u_av, v_av, h, uh, vh, G, GV, US, symmetric=sym) - call check_redundant("Start predictor u ", u_av, v_av, G, unscale=US%L_T_to_m_s) - call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Start predictor u ", u_av, v_av, G, unscale=US%L_T_to_m_s) + call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) @@ -552,7 +561,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%AD_pred) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with predictor horizontal_viscosity (step_MOM_dyn_split_RK2b)") @@ -577,10 +586,12 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + if (debug_redundant) then + call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif endif call cpu_clock_begin(id_clock_vertvisc) @@ -599,7 +610,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call disable_averaging(CS%diag) if (CS%debug) then - call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) endif call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) @@ -690,24 +701,26 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call cpu_clock_end(id_clock_mom_update) if (CS%debug) then - call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & - symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) ! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1, & symmetric=sym) - call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) - call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif ! up <- up + dt_pred d/dz visc d/dz up ! u_av <- u_av + dt_pred d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) if (CS%debug) then - call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) endif ! if (CS%fpmix) then @@ -742,7 +755,11 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + if (CS%visc_rem_dt_bug) then + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + else + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + endif call cpu_clock_end(id_clock_vertvisc) call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) @@ -765,12 +782,12 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc if (associated(CS%OBC)) then if (CS%debug) & - call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt_pred) if (CS%debug) & - call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) endif ! h_av = (h + hp)/2 @@ -829,17 +846,19 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc if (CS%debug) then call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, scale=GV%H_to_MKS) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, unscale=GV%H_to_MKS) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) - call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) - call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%ADp) + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%ADp) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2b)") @@ -872,10 +891,12 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + if (debug_redundant) then + call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif endif ! u_accel_bt = layer accelerations due to barotropic solver @@ -898,7 +919,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call cpu_clock_end(id_clock_btstep) if (showCallTree) call callTree_leave("btstep()") - if (CS%debug) then + if (CS%debug .and. debug_redundant) then call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2) endif @@ -918,10 +939,10 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call cpu_clock_end(id_clock_mom_update) if (CS%debug) then - call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & - symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & @@ -1114,7 +1135,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc if (CS%debug) then call MOM_state_chksum("Corrector ", u_av, v_av, h, uh, vh, G, GV, US, symmetric=sym) - ! call uvchksum("Corrector inst [uv]", u_inst, v_inst, G%HI, symmetric=sym, scale=US%L_T_to_m_s) + ! call uvchksum("Corrector inst [uv]", u_inst, v_inst, G%HI, symmetric=sym, unscale=US%L_T_to_m_s) endif if (showCallTree) call callTree_leave("step_MOM_dyn_split_RK2b()") @@ -1216,7 +1237,7 @@ end subroutine remap_dyn_split_RK2b_aux_vars !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, param_file, & - diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & + diag, CS, HA_CSp, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil) @@ -1239,6 +1260,8 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, type(param_file_type), intent(in) :: param_file !< parameter file for parsing type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + type(harmonic_analysis_CS), pointer :: HA_CSp !< A pointer to the control structure of the + !! harmonic analysis module type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure real, intent(in) :: dt !< time step [T ~> s] type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for @@ -1272,6 +1295,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, character(len=48) :: thickness_units, flux_units, eta_rest_name logical :: debug_truncations logical :: read_uv, read_h2 + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB @@ -1330,6 +1354,17 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & + "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& + "for in two places. This parameter controls the defaults of two individual "//& + "flags, VISC_REM_TIMESTEP_BUG in MOM_dynamics_split_RK2(b) and "//& + "VISC_REM_BT_WEIGHT_BUG in MOM_barotropic.", default=.true.) + call get_param(param_file, mdl, "VISC_REM_TIMESTEP_BUG", CS%visc_rem_dt_bug, & + "If true, recover a bug that uses dt_pred rather than dt in "//& + "vertvisc_remnant() at the end of predictor stage for the following "//& + "continuity() and btstep() calls in the corrector step. Default of this flag "//& + "is set by VISC_REM_BUG", default=visc_rem_bug) + allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) @@ -1385,7 +1420,12 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) - if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%use_tides) then + call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp, CS%HA_CSp) + HA_CSp => CS%HA_CSp + else + HA_CSp => NULL() + endif call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) @@ -1423,7 +1463,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & - CS%SAL_CSp) + CS%SAL_CSp, HA_CSp) flux_units = get_flux_units(GV) thickness_units = get_thickness_units(GV) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 579ddead2d..72c7dbe6cd 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -263,7 +263,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt) + call horizontal_viscosity(u, v, h, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 65b3bdf50e..cc37f1c2bc 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -275,7 +275,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt,Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_in, v_in, h_in, CS%diffu, CS%diffv, MEKE, VarMix, & + call horizontal_viscosity(u_in, v_in, h_in, uh, vh, CS%diffu, CS%diffv, MEKE, VarMix, & G, GV, US, CS%hor_visc, tv, dt) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 02855c9fe6..998713d1f1 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -6,7 +6,7 @@ module MOM_forcing_type use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_destructor use MOM_coupler_types, only : coupler_type_increment_data, coupler_type_initialized -use MOM_coupler_types, only : coupler_type_copy_data +use MOM_coupler_types, only : coupler_type_copy_data, coupler_type_spawn use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, register_diag_field, register_scalar_field @@ -1262,89 +1262,89 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. if (associated(fluxes%ustar)) & - call hchksum(fluxes%ustar, mesg//" fluxes%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(fluxes%ustar, mesg//" fluxes%ustar", G%HI, haloshift=hshift, unscale=US%Z_to_m*US%s_to_T) if (associated(fluxes%tau_mag)) & - call hchksum(fluxes%tau_mag, mesg//" fluxes%tau_mag", G%HI, haloshift=hshift, scale=US%RLZ_T2_to_Pa) + call hchksum(fluxes%tau_mag, mesg//" fluxes%tau_mag", G%HI, haloshift=hshift, unscale=US%RLZ_T2_to_Pa) if (associated(fluxes%buoy)) & - call hchksum(fluxes%buoy, mesg//" fluxes%buoy ", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(fluxes%buoy, mesg//" fluxes%buoy ", G%HI, haloshift=hshift, unscale=US%L_to_m**2*US%s_to_T**3) if (associated(fluxes%sw)) & - call hchksum(fluxes%sw, mesg//" fluxes%sw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw, mesg//" fluxes%sw", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dir)) & - call hchksum(fluxes%sw_vis_dir, mesg//" fluxes%sw_vis_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_vis_dir, mesg//" fluxes%sw_vis_dir", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dif)) & - call hchksum(fluxes%sw_vis_dif, mesg//" fluxes%sw_vis_dif", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_vis_dif, mesg//" fluxes%sw_vis_dif", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dir)) & - call hchksum(fluxes%sw_nir_dir, mesg//" fluxes%sw_nir_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_nir_dir, mesg//" fluxes%sw_nir_dir", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dif)) & - call hchksum(fluxes%sw_nir_dif, mesg//" fluxes%sw_nir_dif", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_nir_dif, mesg//" fluxes%sw_nir_dif", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%lw)) & - call hchksum(fluxes%lw, mesg//" fluxes%lw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%lw, mesg//" fluxes%lw", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent)) & - call hchksum(fluxes%latent, mesg//" fluxes%latent", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%latent, mesg//" fluxes%latent", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_evap_diag)) & call hchksum(fluxes%latent_evap_diag, mesg//" fluxes%latent_evap_diag", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_fprec_diag)) & call hchksum(fluxes%latent_fprec_diag, mesg//" fluxes%latent_fprec_diag", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_frunoff_diag)) & call hchksum(fluxes%latent_frunoff_diag, mesg//" fluxes%latent_frunoff_diag", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sens)) & - call hchksum(fluxes%sens, mesg//" fluxes%sens", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sens, mesg//" fluxes%sens", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%evap)) & - call hchksum(fluxes%evap, mesg//" fluxes%evap", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%evap, mesg//" fluxes%evap", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%lprec)) & - call hchksum(fluxes%lprec, mesg//" fluxes%lprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%lprec, mesg//" fluxes%lprec", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%fprec)) & - call hchksum(fluxes%fprec, mesg//" fluxes%fprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%fprec, mesg//" fluxes%fprec", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%vprec)) & - call hchksum(fluxes%vprec, mesg//" fluxes%vprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%vprec, mesg//" fluxes%vprec", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%seaice_melt)) & - call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%seaice_melt_heat)) & call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%p_surf)) & - call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf", G%HI, haloshift=hshift, scale=US%RL2_T2_to_Pa) + call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf", G%HI, haloshift=hshift, unscale=US%RL2_T2_to_Pa) if (associated(fluxes%u10_sqr)) & - call hchksum(fluxes%u10_sqr, mesg//" fluxes%u10_sqr", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**2) + call hchksum(fluxes%u10_sqr, mesg//" fluxes%u10_sqr", G%HI, haloshift=hshift, unscale=US%L_to_m**2*US%s_to_T**2) if (associated(fluxes%ice_fraction)) & call hchksum(fluxes%ice_fraction, mesg//" fluxes%ice_fraction", G%HI, haloshift=hshift) if (associated(fluxes%salt_flux)) & - call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%TKE_tidal)) & - call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal", G%HI, haloshift=hshift, scale=US%RZ3_T3_to_W_m2) + call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal", G%HI, haloshift=hshift, unscale=US%RZ3_T3_to_W_m2) if (associated(fluxes%ustar_tidal)) & - call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal", G%HI, haloshift=hshift, unscale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & - call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%frunoff)) & - call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%heat_content_lrunoff)) & call hchksum(fluxes%heat_content_lrunoff, mesg//" fluxes%heat_content_lrunoff", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_frunoff)) & call hchksum(fluxes%heat_content_frunoff, mesg//" fluxes%heat_content_frunoff", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_lprec)) & call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_fprec)) & call hchksum(fluxes%heat_content_fprec, mesg//" fluxes%heat_content_fprec", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_cond)) & call hchksum(fluxes%heat_content_cond, mesg//" fluxes%heat_content_cond", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_evap)) & call hchksum(fluxes%heat_content_evap, mesg//" fluxes%heat_content_evap", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_massout)) & call hchksum(fluxes%heat_content_massout, mesg//" fluxes%heat_content_massout", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_massin)) & call hchksum(fluxes%heat_content_massin, mesg//" fluxes%heat_content_massin", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) end subroutine MOM_forcing_chksum !> Write out chksums for the driving mechanical forces. @@ -1364,17 +1364,17 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) ! and js...je as their extent. if (associated(forces%taux) .and. associated(forces%tauy)) & call uvchksum(mesg//" forces%tau[xy]", forces%taux, forces%tauy, G%HI, & - haloshift=hshift, symmetric=.true., scale=US%RLZ_T2_to_Pa) + haloshift=hshift, symmetric=.true., unscale=US%RLZ_T2_to_Pa) if (associated(forces%p_surf)) & - call hchksum(forces%p_surf, mesg//" forces%p_surf", G%HI, haloshift=hshift, scale=US%RL2_T2_to_Pa) + call hchksum(forces%p_surf, mesg//" forces%p_surf", G%HI, haloshift=hshift, unscale=US%RL2_T2_to_Pa) if (associated(forces%ustar)) & - call hchksum(forces%ustar, mesg//" forces%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(forces%ustar, mesg//" forces%ustar", G%HI, haloshift=hshift, unscale=US%Z_to_m*US%s_to_T) if (associated(forces%tau_mag)) & - call hchksum(forces%tau_mag, mesg//" forces%tau_mag", G%HI, haloshift=hshift, scale=US%RLZ_T2_to_Pa) + call hchksum(forces%tau_mag, mesg//" forces%tau_mag", G%HI, haloshift=hshift, unscale=US%RLZ_T2_to_Pa) if (associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) & call uvchksum(mesg//" forces%rigidity_ice_[uv]", forces%rigidity_ice_u, & forces%rigidity_ice_v, G%HI, haloshift=hshift, symmetric=.true., & - scale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) + unscale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) end subroutine MOM_mech_forcing_chksum @@ -2627,7 +2627,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (turns /= 0) then G => diag%G allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=turns) call rotate_forcing(fluxes_in, fluxes, turns) else G => G_in @@ -2657,7 +2657,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_prcme > 0) call post_data(handles%id_prcme, res, diag) if (handles%id_total_prcme > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(res, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_prcme, total_transport, diag) endif if (handles%id_prcme_ga > 0) then @@ -2684,7 +2684,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_massout > 0) call post_data(handles%id_net_massout, res, diag) if (handles%id_total_net_massout > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(res, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_net_massout, total_transport, diag) endif endif @@ -2716,7 +2716,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_massin > 0) call post_data(handles%id_net_massin, res, diag) if (handles%id_total_net_massin > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(res, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_net_massin, total_transport, diag) endif endif @@ -2727,7 +2727,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_evap > 0) .and. associated(fluxes%evap)) & call post_data(handles%id_evap, fluxes%evap, diag) if ((handles%id_total_evap > 0) .and. associated(fluxes%evap)) then - total_transport = global_area_integral(fluxes%evap, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%evap, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_evap, total_transport, diag) endif if ((handles%id_evap_ga > 0) .and. associated(fluxes%evap)) then @@ -2741,7 +2741,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_precip > 0) call post_data(handles%id_precip, res, diag) if (handles%id_total_precip > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(res, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_precip, total_transport, diag) endif if (handles%id_precip_ga > 0) then @@ -2753,7 +2753,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%lprec)) then if (handles%id_lprec > 0) call post_data(handles%id_lprec, fluxes%lprec, diag) if (handles%id_total_lprec > 0) then - total_transport = global_area_integral(fluxes%lprec, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%lprec, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_lprec, total_transport, diag) endif if (handles%id_lprec_ga > 0) then @@ -2765,7 +2765,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%fprec)) then if (handles%id_fprec > 0) call post_data(handles%id_fprec, fluxes%fprec, diag) if (handles%id_total_fprec > 0) then - total_transport = global_area_integral(fluxes%fprec, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%fprec, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_fprec, total_transport, diag) endif if (handles%id_fprec_ga > 0) then @@ -2777,7 +2777,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%vprec)) then if (handles%id_vprec > 0) call post_data(handles%id_vprec, fluxes%vprec, diag) if (handles%id_total_vprec > 0) then - total_transport = global_area_integral(fluxes%vprec, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%vprec, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_vprec, total_transport, diag) endif if (handles%id_vprec_ga > 0) then @@ -2789,7 +2789,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%lrunoff)) then if (handles%id_lrunoff > 0) call post_data(handles%id_lrunoff, fluxes%lrunoff, diag) if (handles%id_total_lrunoff > 0) then - total_transport = global_area_integral(fluxes%lrunoff, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%lrunoff, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_lrunoff, total_transport, diag) endif endif @@ -2797,7 +2797,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%frunoff)) then if (handles%id_frunoff > 0) call post_data(handles%id_frunoff, fluxes%frunoff, diag) if (handles%id_total_frunoff > 0) then - total_transport = global_area_integral(fluxes%frunoff, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%frunoff, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_frunoff, total_transport, diag) endif endif @@ -2805,7 +2805,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%seaice_melt)) then if (handles%id_seaice_melt > 0) call post_data(handles%id_seaice_melt, fluxes%seaice_melt, diag) if (handles%id_total_seaice_melt > 0) then - total_transport = global_area_integral(fluxes%seaice_melt, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%seaice_melt, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_seaice_melt, total_transport, diag) endif endif @@ -2815,63 +2815,63 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) & call post_data(handles%id_heat_content_lrunoff, fluxes%heat_content_lrunoff, diag) if ((handles%id_total_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) then - total_transport = global_area_integral(fluxes%heat_content_lrunoff, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_lrunoff, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_lrunoff, total_transport, diag) endif if ((handles%id_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) & call post_data(handles%id_heat_content_frunoff, fluxes%heat_content_frunoff, diag) if ((handles%id_total_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) then - total_transport = global_area_integral(fluxes%heat_content_frunoff, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_frunoff, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_frunoff, total_transport, diag) endif if ((handles%id_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) & call post_data(handles%id_heat_content_lprec, fluxes%heat_content_lprec, diag) if ((handles%id_total_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) then - total_transport = global_area_integral(fluxes%heat_content_lprec, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_lprec, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_lprec, total_transport, diag) endif if ((handles%id_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) & call post_data(handles%id_heat_content_fprec, fluxes%heat_content_fprec, diag) if ((handles%id_total_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) then - total_transport = global_area_integral(fluxes%heat_content_fprec, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_fprec, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_fprec, total_transport, diag) endif if ((handles%id_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) & call post_data(handles%id_heat_content_vprec, fluxes%heat_content_vprec, diag) if ((handles%id_total_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) then - total_transport = global_area_integral(fluxes%heat_content_vprec, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_vprec, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_vprec, total_transport, diag) endif if ((handles%id_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) & call post_data(handles%id_heat_content_cond, fluxes%heat_content_cond, diag) if ((handles%id_total_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) then - total_transport = global_area_integral(fluxes%heat_content_cond, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_cond, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_cond, total_transport, diag) endif if ((handles%id_heat_content_evap > 0) .and. associated(fluxes%heat_content_evap)) & call post_data(handles%id_heat_content_evap, fluxes%heat_content_evap, diag) if ((handles%id_total_heat_content_evap > 0) .and. associated(fluxes%heat_content_evap)) then - total_transport = global_area_integral(fluxes%heat_content_evap, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_evap, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_evap, total_transport, diag) endif if ((handles%id_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) & call post_data(handles%id_heat_content_massout, fluxes%heat_content_massout, diag) if ((handles%id_total_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) then - total_transport = global_area_integral(fluxes%heat_content_massout, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_massout, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_massout, total_transport, diag) endif if ((handles%id_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) & call post_data(handles%id_heat_content_massin, fluxes%heat_content_massin, diag) if ((handles%id_total_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) then - total_transport = global_area_integral(fluxes%heat_content_massin, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_massin, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_massin, total_transport, diag) endif @@ -2887,7 +2887,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_heat_coupler > 0) call post_data(handles%id_net_heat_coupler, res, diag) if (handles%id_total_net_heat_coupler > 0) then - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(res, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_net_heat_coupler, total_transport, diag) endif if (handles%id_net_heat_coupler_ga > 0) then @@ -2930,7 +2930,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (handles%id_net_heat_surface > 0) call post_data(handles%id_net_heat_surface, res, diag) if (handles%id_total_net_heat_surface > 0) then - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(res, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_net_heat_surface, total_transport, diag) endif if (handles%id_net_heat_surface_ga > 0) then @@ -2956,7 +2956,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_heat_content_surfwater > 0) call post_data(handles%id_heat_content_surfwater, res, diag) if (handles%id_total_heat_content_surfwater > 0) then - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(res, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_surfwater, total_transport, diag) endif endif @@ -2995,7 +2995,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h do j=js,je ; do i=is,ie res(i,j) = (fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) enddo ; enddo - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(res, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_LwLatSens, total_transport, diag) endif @@ -3020,7 +3020,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_sw_nir, fluxes%sw_nir_dir+fluxes%sw_nir_dif, diag) endif if ((handles%id_total_sw > 0) .and. associated(fluxes%sw)) then - total_transport = global_area_integral(fluxes%sw, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%sw, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_sw, total_transport, diag) endif if ((handles%id_sw_ga > 0) .and. associated(fluxes%sw)) then @@ -3032,7 +3032,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_lw, fluxes%lw, diag) endif if ((handles%id_total_lw > 0) .and. associated(fluxes%lw)) then - total_transport = global_area_integral(fluxes%lw, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%lw, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lw, total_transport, diag) endif if ((handles%id_lw_ga > 0) .and. associated(fluxes%lw)) then @@ -3044,7 +3044,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_lat, fluxes%latent, diag) endif if ((handles%id_total_lat > 0) .and. associated(fluxes%latent)) then - total_transport = global_area_integral(fluxes%latent, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%latent, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat, total_transport, diag) endif if ((handles%id_lat_ga > 0) .and. associated(fluxes%latent)) then @@ -3056,7 +3056,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_lat_evap, fluxes%latent_evap_diag, diag) endif if ((handles%id_total_lat_evap > 0) .and. associated(fluxes%latent_evap_diag)) then - total_transport = global_area_integral(fluxes%latent_evap_diag, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%latent_evap_diag, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat_evap, total_transport, diag) endif @@ -3064,7 +3064,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_lat_fprec, fluxes%latent_fprec_diag, diag) endif if ((handles%id_total_lat_fprec > 0) .and. associated(fluxes%latent_fprec_diag)) then - total_transport = global_area_integral(fluxes%latent_fprec_diag, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%latent_fprec_diag, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat_fprec, total_transport, diag) endif @@ -3072,7 +3072,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_lat_frunoff, fluxes%latent_frunoff_diag, diag) endif if (handles%id_total_lat_frunoff > 0 .and. associated(fluxes%latent_frunoff_diag)) then - total_transport = global_area_integral(fluxes%latent_frunoff_diag, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%latent_frunoff_diag, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat_frunoff, total_transport, diag) endif @@ -3085,12 +3085,12 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h endif if ((handles%id_total_seaice_melt_heat > 0) .and. associated(fluxes%seaice_melt_heat)) then - total_transport = global_area_integral(fluxes%seaice_melt_heat, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%seaice_melt_heat, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_seaice_melt_heat, total_transport, diag) endif if ((handles%id_total_sens > 0) .and. associated(fluxes%sens)) then - total_transport = global_area_integral(fluxes%sens, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%sens, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_sens, total_transport, diag) endif if ((handles%id_sens_ga > 0) .and. associated(fluxes%sens)) then @@ -3103,7 +3103,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h endif if ((handles%id_total_heat_added > 0) .and. associated(fluxes%heat_added)) then - total_transport = global_area_integral(fluxes%heat_added, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_added, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_added, total_transport, diag) endif @@ -3113,21 +3113,21 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_saltflux > 0) .and. associated(fluxes%salt_flux)) & call post_data(handles%id_saltflux, fluxes%salt_flux, diag) if ((handles%id_total_saltflux > 0) .and. associated(fluxes%salt_flux)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux, G, scale=US%RZ_T_to_kg_m2s) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_saltflux, total_transport, diag) endif if ((handles%id_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) & call post_data(handles%id_saltFluxAdded, fluxes%salt_flux_added, diag) if ((handles%id_total_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added, G, scale=US%RZ_T_to_kg_m2s) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_saltFluxAdded, total_transport, diag) endif if (handles%id_saltFluxIn > 0 .and. associated(fluxes%salt_flux_in)) & call post_data(handles%id_saltFluxIn, fluxes%salt_flux_in, diag) if ((handles%id_total_saltFluxIn > 0) .and. associated(fluxes%salt_flux_in)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in, G, scale=US%RZ_T_to_kg_m2s) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_saltFluxIn, total_transport, diag) endif @@ -3308,13 +3308,16 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & end subroutine allocate_forcing_by_group !> Allocate elements of a new forcing type based on their status in an existing type. -subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) +subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes, turns) type(forcing), intent(in) :: fluxes_ref !< Reference fluxes type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes type(forcing), intent(out) :: fluxes !< Target fluxes + integer, optional, intent(in) :: turns !< If present, the number of counterclockwise + !! quarter turns to use on the new grid. logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf logical :: do_iceberg, do_heat_added, do_buoy + logical :: even_turns ! True if turns is absent or even call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_taumag, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) @@ -3353,6 +3356,19 @@ subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) ! This flag would normally be set by a control flag in allocate_forcing_type. ! Here we copy the flag from the reference forcing. fluxes%gustless_accum_bug = fluxes_ref%gustless_accum_bug + + if (coupler_type_initialized(fluxes_ref%tr_fluxes)) then + ! The data fields in the coupler_2d_bc_type are never rotated. + even_turns = .true. ; if (present(turns)) even_turns = (modulo(turns, 2) == 0) + if (even_turns) then + call coupler_type_spawn(fluxes_ref%tr_fluxes, fluxes%tr_fluxes, & + (/G%isc,G%isc,G%iec,G%iec/), (/G%jsc,G%jsc,G%jec,G%jec/)) + else + call coupler_type_spawn(fluxes_ref%tr_fluxes, fluxes%tr_fluxes, & + (/G%jsc,G%jsc,G%jec,G%jec/), (/G%isc,G%isc,G%iec,G%iec/)) + endif + endif + end subroutine allocate_forcing_by_ref diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 3891c86e3a..c594aed206 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -307,11 +307,11 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) tv%valid_SpV_halo = halos if (do_debug) then - call hchksum(h, "derived_thermo h", G%HI, haloshift=halos, scale=GV%H_to_MKS) + call hchksum(h, "derived_thermo h", G%HI, haloshift=halos, unscale=GV%H_to_MKS) if (associated(tv%p_surf)) call hchksum(tv%p_surf, "derived_thermo p_surf", G%HI, & - haloshift=halos, scale=US%RL2_T2_to_Pa) - call hchksum(tv%T, "derived_thermo T", G%HI, haloshift=halos, scale=US%C_to_degC) - call hchksum(tv%S, "derived_thermo S", G%HI, haloshift=halos, scale=US%S_to_ppt) + haloshift=halos, unscale=US%RL2_T2_to_Pa) + call hchksum(tv%T, "derived_thermo T", G%HI, haloshift=halos, unscale=US%C_to_degC) + call hchksum(tv%S, "derived_thermo S", G%HI, haloshift=halos, unscale=US%S_to_ppt) endif elseif (allocated(tv%Spv_avg)) then do k=1,nz ; SpV_lay(k) = 1.0 / GV%Rlay(k) ; enddo @@ -394,10 +394,12 @@ end subroutine find_col_avg_SpV !> Determine the in situ density averaged over a specified distance from the bottom, !! calculating it as the inverse of the mass-weighted average specific volume. -subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) +subroutine find_rho_bottom(G, GV, US, tv, h, dz, pres_int, dz_avg, j, Rho_bot, h_bot, k_bot) 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(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZK_(GV)), & @@ -405,10 +407,10 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) real, dimension(SZI_(G),SZK_(GV)+1), & intent(in) :: pres_int !< Pressure at each interface [R L2 T-2 ~> Pa] real, dimension(SZI_(G)), intent(in) :: dz_avg !< The vertical distance over which to average [Z ~> m] - type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available - !! thermodynamic fields. integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + real, dimension(SZI_(G)), intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G)), intent(out) :: k_bot !< Bottom boundary layer top layer index ! Local variables real :: hb(SZI_(G)) ! Running sum of the thickness in the bottom boundary layer [H ~> m or kg m-2] @@ -441,6 +443,53 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) do i=is,ie rho_bot(i) = GV%Rho0 enddo + + ! Obtain bottom boundary layer thickness and index of top layer + do i=is,ie + hb(i) = 0.0 ; h_bot(i) = 0.0 ; k_bot(i) = nz + dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) + do_i(i) = .true. + if (G%mask2dT(i,j) <= 0.0) then + h_bbl_frac(i) = 0.0 + do_i(i) = .false. + endif + enddo + + do k=nz,1,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + if (dz(i,k) < dz_bbl_rem(i)) then + ! This layer is fully within the averaging depth. + dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) + hb(i) = hb(i) + h(i,j,k) + k_bot(i) = k + do_any = .true. + else + if (dz(i,k) > 0.0) then + frac_in = dz_bbl_rem(i) / dz(i,k) + if (frac_in >= 0.5) k_bot(i) = k ! update bbl top index if >= 50% of layer + else + frac_in = 0.0 + endif + h_bbl_frac(i) = frac_in * h(i,j,k) + dz_bbl_rem(i) = 0.0 + do_i(i) = .false. + endif + endif ; enddo + if (.not.do_any) exit + enddo + do i=is,ie ; if (do_i(i)) then + ! The nominal bottom boundary layer is thicker than the water column, but layer 1 is + ! already included in the averages. These values are set so that the call to find + ! the layer-average specific volume will behave sensibly. + h_bbl_frac(i) = 0.0 + endif ; enddo + + do i=is,ie + if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff + h_bot(i) = hb(i) + h_bbl_frac(i) + enddo + else ! Check that SpV_avg has been set. if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & @@ -450,7 +499,7 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) ! specified distance, with care taken to avoid having compressibility lead to an imprint ! of the layer thicknesses on this density. do i=is,ie - hb(i) = 0.0 ; SpV_h_bot(i) = 0.0 + hb(i) = 0.0 ; SpV_h_bot(i) = 0.0 ; h_bot(i) = 0.0 ; k_bot(i) = nz dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) do_i(i) = .true. if (G%mask2dT(i,j) <= 0.0) then @@ -470,10 +519,12 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) SpV_h_bot(i) = SpV_h_bot(i) + h(i,j,k) * tv%SpV_avg(i,j,k) dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) hb(i) = hb(i) + h(i,j,k) + k_bot(i) = k do_any = .true. else if (dz(i,k) > 0.0) then frac_in = dz_bbl_rem(i) / dz(i,k) + if (frac_in >= 0.5) k_bot(i) = k ! update bbl top index if >= 50% of layer else frac_in = 0.0 endif @@ -516,6 +567,7 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) do i=is,ie if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff rho_bot(i) = G%mask2dT(i,j) * (hb(i) + h_bbl_frac(i)) / (SpV_h_bot(i) + h_bbl_frac(i)*SpV_bbl(i)) + h_bot(i) = hb(i) + h_bbl_frac(i) enddo endif diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index ede5137cb6..cdba3e0ba9 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -240,15 +240,19 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo ; enddo enddo + do I=is-1,ie + GxSpV_u(I) = G_Rho0 !This will be changed if both use_EOS and allocated(tv%SpV_avg) are true + enddo !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & !$OMP h_neglect,dz_neglect,h_neglect2, & !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSxN,EOSdom_u,EOSdom_h1, & !$OMP local_open_u_BC,dzu,OBC,use_stanley) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,GxSpV_u, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,slope,l_seg) + !$OMP drdx,mag_grad2,slope,l_seg) & + !$OMP firstprivate(GxSpV_u) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -270,10 +274,6 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan GxSpV_u(I) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + & (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i+1,j,k-1))) enddo - else - do I=is-1,ie - GxSpV_u(I) = G_Rho0 - enddo endif endif endif @@ -356,8 +356,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan slope = 0.0 endif else ! With .not.use_EOS, the layers are constant density. - slope = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu(I,j) + slope = (e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j) endif + if (local_open_u_BC) then l_seg = OBC%segnum_u(I,j) if (l_seg /= OBC_NONE) then @@ -372,7 +373,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! endif endif endif - slope = slope * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) + slope = slope * max(G%mask2dT(i,j), G%mask2dT(i+1,j)) endif slope_x(I,j,K) = slope if (present(dzSxN)) & @@ -383,6 +384,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo ! I enddo ; enddo ! end of j-loop + do i=is,ie + GxSpV_v(i) = G_Rho0 !This will be changed if both use_EOS and allocated(tv%SpV_avg) are true + enddo ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect, & @@ -390,11 +394,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan !$OMP dzv,local_open_v_BC,OBC,use_stanley) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,GxSpV_v, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & !$OMP drho_dT_dT_hr,pres_hr,T_hr,S_hr, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,slope,l_seg) - do j=js-1,je ; do K=nz,2,-1 + !$OMP drdy,mag_grad2,slope,l_seg) & + !$OMP firstprivate(GxSpV_v) + do J=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = GV%Rlay(k)-GV%Rlay(k-1) @@ -415,10 +420,6 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan GxSpV_v(i) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + & (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j+1,k-1))) enddo - else - do i=is,ie - GxSpV_v(i) = G_Rho0 - enddo endif endif endif @@ -504,11 +505,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan else ! Just in case mag_grad2 = 0 ever. slope = 0.0 endif - - else ! With .not.use_EOS, the layers are constant density. - slope = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv(i,J) + slope = (e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J) endif + if (local_open_v_BC) then l_seg = OBC%segnum_v(i,J) if (l_seg /= OBC_NONE) then @@ -523,7 +523,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! endif endif endif - slope = slope * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) + slope = slope * max(G%mask2dT(i,j), G%mask2dT(i,j+1)) endif slope_y(i,J,K) = slope if (present(dzSyN)) & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 4dcbad4388..f89c8953ab 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -41,6 +41,7 @@ module MOM_open_boundary public open_boundary_apply_normal_flow public open_boundary_config +public open_boundary_setup_vert public open_boundary_init public open_boundary_query public open_boundary_end @@ -346,7 +347,10 @@ module MOM_open_boundary real :: rx_max !< The maximum magnitude of the baroclinic radiation velocity (or speed of !! characteristics) in units of grid points per timestep [nondim]. logical :: OBC_pe !< Is there an open boundary on this tile? - type(remapping_CS), pointer :: remap_CS=> NULL() !< ALE remapping control structure for segments only + type(remapping_CS), pointer :: remap_z_CS=> NULL() !< ALE remapping control structure for + !! z-space data on segments + type(remapping_CS), pointer :: remap_h_CS=> NULL() !< ALE remapping control structure for + !! thickness-based fields on segments type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries real, allocatable :: rx_normal(:,:,:) !< Array storage for normal phase speed for EW radiation OBCs in units of !! grid points per timestep [nondim] @@ -382,6 +386,11 @@ module MOM_open_boundary !! for remapping. Values below 20190101 recover the remapping !! answers from 2018, while higher values use more robust !! forms of the same remapping expressions. + logical :: check_reconstruction !< Flag for remapping to run checks on reconstruction + logical :: check_remapping !< Flag for remapping to run internal checks + logical :: force_bounds_in_subcell !< Flag for remapping to hide overshoot using bounds + logical :: om4_remap_via_sub_cells !< If true, use the OM4 remapping algorithm + character(40) :: remappingScheme !< String selecting the vertical remapping scheme type(group_pass_type) :: pass_oblique !< Structure for group halo pass end type ocean_OBC_type @@ -425,7 +434,6 @@ module MOM_open_boundary !> and ALE_init. Therefore segment data are not fully initialized !> here. The remainder of the segment data are initialized in a !> later call to update_open_boundary_data - subroutine open_boundary_config(G, US, param_file, OBC) type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -440,8 +448,8 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: check_reconstruction, check_remapping, force_bounds_in_subcell - character(len=64) :: remappingScheme + logical :: check_remapping, force_bounds_in_subcell + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm ! This include declares and sets the variable "version". # include "version_variable.h" @@ -666,23 +674,25 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo - call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & + call get_param(param_file, mdl, "REMAPPING_SCHEME", OBC%remappingScheme, & + default=remappingDefaultScheme, do_not_log=.true.) + call get_param(param_file, mdl, "OBC_REMAPPING_SCHEME", OBC%remappingScheme, & "This sets the reconstruction scheme used "//& - "for vertical remapping for all variables. "//& + "for OBC vertical remapping for all variables. "//& "It can be one of the following schemes: \n"//& - trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) - call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & + trim(remappingSchemesDoc), default=OBC%remappingScheme) + call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", OBC%check_reconstruction, & "If true, cell-by-cell reconstructions are checked for "//& "consistency and if non-monotonicity or an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) - call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & + call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", OBC%check_remapping, & "If true, the results of remapping are checked for "//& "conservation and new extrema and if an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & "If true, read external OBC data on the supergrid.", & default=.false.) - call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & + call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", OBC%force_bounds_in_subcell, & "If true, the values on the intermediate grid used for remapping "//& "are forced to be bounded, which might not be the case due to "//& "round off.", default=.false.,do_not_log=.true.) @@ -695,11 +705,10 @@ subroutine open_boundary_config(G, US, param_file, OBC) "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date) - - allocate(OBC%remap_CS) - call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & - check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answer_date=OBC%remap_answer_date) + call get_param(param_file, mdl, "OBC_REMAPPING_USE_OM4_SUBCELLS", OBC%om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for neutral diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) endif ! OBC%number_of_segments > 0 @@ -723,6 +732,41 @@ subroutine open_boundary_config(G, US, param_file, OBC) end subroutine open_boundary_config +!> Setup vertical remapping for open boundaries +subroutine open_boundary_setup_vert(GV, US, OBC) + type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + + ! Local variables + real :: dz_neglect, dz_neglect_edge ! Small thicknesses in vertical height units [Z ~> m] + + if (associated(OBC)) then + if (OBC%number_of_segments > 0) then + if (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10 + elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-10 + else + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + endif + allocate(OBC%remap_z_CS) + call initialize_remapping(OBC%remap_z_CS, OBC%remappingScheme, boundary_extrapolation=.false., & + check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & + om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & + force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & + h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) + allocate(OBC%remap_h_CS) + call initialize_remapping(OBC%remap_h_CS, OBC%remappingScheme, boundary_extrapolation=.false., & + check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & + om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & + force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) + endif + endif + +end subroutine open_boundary_setup_vert + !> Allocate space for reading OBC data from files. It sets up the required vertical !! remapping. In the process, it does funky stuff with the MPI processes. subroutine initialize_segment_data(G, GV, US, OBC, PF) @@ -1967,6 +2011,8 @@ subroutine open_boundary_dealloc(OBC) if (allocated(OBC%cff_normal_v)) deallocate(OBC%cff_normal_v) if (allocated(OBC%tres_x)) deallocate(OBC%tres_x) if (allocated(OBC%tres_y)) deallocate(OBC%tres_y) + if (associated(OBC%remap_z_CS)) deallocate(OBC%remap_z_CS) + if (associated(OBC%remap_h_CS)) deallocate(OBC%remap_h_CS) deallocate(OBC) end subroutine open_boundary_dealloc @@ -3312,22 +3358,22 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, sym = G%Domain%symmetric if (OBC%radiation_BCs_exist_globally) then call uvchksum("radiation_OBCs: OBC%r[xy]_normal", OBC%rx_normal, OBC%ry_normal, G%HI, & - haloshift=0, symmetric=sym, scale=1.0) + haloshift=0, symmetric=sym, unscale=1.0) endif if (OBC%oblique_BCs_exist_globally) then call uvchksum("radiation_OBCs: OBC%r[xy]_oblique_[uv]", OBC%rx_oblique_u, OBC%ry_oblique_v, G%HI, & - haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + haloshift=0, symmetric=sym, unscale=1.0/US%L_T_to_m_s**2) call uvchksum("radiation_OBCs: OBC%r[yx]_oblique_[uv]", OBC%ry_oblique_u, OBC%rx_oblique_v, G%HI, & - haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + haloshift=0, symmetric=sym, unscale=1.0/US%L_T_to_m_s**2) call uvchksum("radiation_OBCs: OBC%cff_normal_[uv]", OBC%cff_normal_u, OBC%cff_normal_v, G%HI, & - haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + haloshift=0, symmetric=sym, unscale=1.0/US%L_T_to_m_s**2) endif if (OBC%ntr == 0) return if (.not. allocated (OBC%tres_x) .or. .not. allocated (OBC%tres_y)) return do m=1,OBC%ntr write(var_num,'(I3.3)') m call uvchksum("radiation_OBCs: OBC%tres_[xy]_"//var_num, OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%HI, & - haloshift=0, symmetric=sym, scale=1.0) + haloshift=0, symmetric=sym, unscale=1.0) enddo endif @@ -3861,7 +3907,6 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) real, allocatable :: normal_trans_bt(:,:) ! barotropic transport [H L2 T-1 ~> m3 s-1] integer :: turns ! Number of index quarter turns real :: time_delta ! Time since tidal reference date [T ~> s] - real :: dz_neglect, dz_neglect_edge ! Small thicknesses [Z ~> m] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3874,14 +3919,6 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (OBC%add_tide_constituents) time_delta = US%s_to_T * time_type_to_real(Time - OBC%time_ref) - if (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then - dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10 - elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then - dz_neglect = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-10 - else - dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff - endif - if (OBC%number_of_segments >= 1) then call thickness_to_dz(h, tv, dz, G, GV, US) call pass_var(dz, G%Domain) @@ -4170,25 +4207,22 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer if (G%mask2dCu(I,j)>0. .and. G%mask2dCu(I,j+1)>0.) then dz_stack(:) = 0.5*(dz(i+ishift,j,:) + dz(i+ishift,j+1,:)) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCu(I,j)>0.) then dz_stack(:) = dz(i+ishift,j,:) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCu(I,j+1)>0.) then dz_stack(:) = dz(i+ishift,j+1,:) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) endif enddo else @@ -4200,11 +4234,10 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) net_dz_src = sum( segment%field(m)%dz_src(I,j,:) ) net_dz_int = sum( dz(i+ishift,j,:) ) scl_fac = net_dz_int / net_dz_src - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,j,:), & - GV%ke, dz(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) endif enddo endif @@ -4220,25 +4253,22 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here dz_stack(:) = 0.5*(dz(i,j+jshift,:) + dz(i+1,j+jshift,:)) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCv(i,J)>0.) then dz_stack(:) = dz(i,j+jshift,:) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCv(i+1,J)>0.) then dz_stack(:) = dz(i+1,j+jshift,:) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) endif enddo else @@ -4250,11 +4280,10 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) net_dz_src = sum( segment%field(m)%dz_src(i,J,:) ) net_dz_int = sum( dz(i,j+jshift,:) ) scl_fac = net_dz_int / net_dz_src - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, scl_fac* segment%field(m)%dz_src(i,J,:), & segment%field(m)%buffer_src(i,J,:), & - GV%ke, dz(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:)) endif enddo endif @@ -5522,7 +5551,6 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] real :: I_scale ! The inverse of the scaling factor for the tracers. ! For salinity the units would be [ppt S-1 ~> 1]. - real :: h_neglect ! Tiny thickness used in remapping [H ~> m or kg m-2] logical :: PCM(GV%ke) ! If true, do PCM remapping from a cell. integer :: i, j, k, m, n, ntr, nz @@ -5530,7 +5558,6 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) nz = GV%ke ntr = OBC%ntr - h_neglect = GV%H_subroundoff if (.not.present(PCM_cell)) PCM(:) = .false. @@ -5560,11 +5587,10 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale if (present(PCM_cell)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column, & + PCM_cell=PCM) else - call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column, & - h_neglect, h_neglect) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column) endif ! Possibly underflow any very tiny tracer concentrations to 0? @@ -5578,8 +5604,8 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif ; enddo if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_rad(I,j,:), nz, h2, r_norm_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%rx_norm_rad(I,j,:), nz, h2, r_norm_col, & + PCM_cell=PCM) do k=1,nz segment%rx_norm_rad(I,j,k) = r_norm_col(k) @@ -5588,14 +5614,14 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif if (segment%oblique .and. (OBC%gamma_uv < 1.0)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_obl(I,j,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%rx_norm_obl(I,j,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%rx_norm_obl(I,j,:) = rxy_col(:) - call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_obl(I,j,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%ry_norm_obl(I,j,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%ry_norm_obl(I,j,:) = rxy_col(:) - call remapping_core_h(OBC%remap_CS, nz, h1, segment%cff_normal(I,j,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%cff_normal(I,j,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%cff_normal(I,j,:) = rxy_col(:) do k=1,nz @@ -5628,11 +5654,10 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale if (present(PCM_cell)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column, & + PCM_cell=PCM) else - call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column, & - h_neglect, h_neglect) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column) endif ! Possibly underflow any very tiny tracer concentrations to 0? @@ -5646,8 +5671,8 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif ; enddo if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_rad(i,J,:), nz, h2, r_norm_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%ry_norm_rad(i,J,:), nz, h2, r_norm_col, & + PCM_cell=PCM) do k=1,nz segment%ry_norm_rad(i,J,k) = r_norm_col(k) @@ -5656,14 +5681,14 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif if (segment%oblique .and. (OBC%gamma_uv < 1.0)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_obl(i,J,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%rx_norm_obl(i,J,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%rx_norm_obl(i,J,:) = rxy_col(:) - call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_obl(i,J,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%ry_norm_obl(i,J,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%ry_norm_obl(i,J,:) = rxy_col(:) - call remapping_core_h(OBC%remap_CS, nz, h1, segment%cff_normal(i,J,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%cff_normal(i,J,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%cff_normal(i,J,:) = rxy_col(:) do k=1,nz @@ -5855,10 +5880,14 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%rx_max = OBC_in%rx_max OBC%OBC_pe = OBC_in%OBC_pe - ! remap_CS is set up by initialize_segment_data, so we copy the fields here. - if (ASSOCIATED(OBC_in%remap_CS)) then - allocate(OBC%remap_CS) - OBC%remap_CS = OBC_in%remap_CS + ! remap_z_CS and remap_h_CS are set up by initialize_segment_data, so we copy the fields here. + if (ASSOCIATED(OBC_in%remap_z_CS)) then + allocate(OBC%remap_z_CS) + OBC%remap_z_CS = OBC_in%remap_z_CS + endif + if (ASSOCIATED(OBC_in%remap_h_CS)) then + allocate(OBC%remap_h_CS) + OBC%remap_h_CS = OBC_in%remap_h_CS endif ! TODO: The OBC registry seems to be a list of "registered" OBC types. diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index 8f872ceb15..e24d4954cb 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -122,16 +122,20 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) A_layer_prev(I,j) = A_layer endif ; enddo ; enddo ; enddo else - do k=nk,1,-1 ; do j=js,je ; do I=Isq,Ieq ; if (do_I(I,j)) then - call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & - eta_u(I,j,K), A_layer, do_I(I,j)) - if (eta_u(I,j,K) - (eta_u(I,j,K+1)+dz_min) > 0.0) then - pbv%por_face_areaU(I,j,k) = min(1.0, (A_layer - A_layer_prev(I,j)) / (eta_u(I,j,K) - eta_u(I,j,K+1))) + do k=nk,1,-1 ; do j=js,je ; do I=Isq,Ieq + if (do_I(I,j)) then + call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), A_layer, do_I(I,j)) + if (eta_u(I,j,K) - (eta_u(I,j,K+1)+dz_min) > 0.0) then + pbv%por_face_areaU(I,j,k) = min(1.0, (A_layer - A_layer_prev(I,j)) / (eta_u(I,j,K) - eta_u(I,j,K+1))) + else + pbv%por_face_areaU(I,j,k) = 0.0 ! use calc_por_interface() might be a better choice + endif + A_layer_prev(I,j) = A_layer else - pbv%por_face_areaU(I,j,k) = 0.0 ! use calc_por_interface() might be a better choice + pbv%por_face_areaU(I,j,k) = 1.0 endif - A_layer_prev(I,j) = A_layer - endif ; enddo ; enddo ; enddo + enddo ; enddo ; enddo endif ! v-points @@ -154,16 +158,20 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) A_layer_prev(i,J) = A_layer endif ; enddo ; enddo ; enddo else - do k=nk,1,-1 ; do J=Jsq,Jeq ; do i=is,ie ; if (do_I(i,J)) then - call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & - eta_v(i,J,K), A_layer, do_I(i,J)) - if (eta_v(i,J,K) - (eta_v(i,J,K+1)+dz_min) > 0.0) then - pbv%por_face_areaV(i,J,k) = min(1.0, (A_layer - A_layer_prev(i,J)) / (eta_v(i,J,K) - eta_v(i,J,K+1))) + do k=nk,1,-1 ; do J=Jsq,Jeq ; do i=is,ie + if (do_I(i,J)) then + call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), A_layer, do_I(i,J)) + if (eta_v(i,J,K) - (eta_v(i,J,K+1)+dz_min) > 0.0) then + pbv%por_face_areaV(i,J,k) = min(1.0, (A_layer - A_layer_prev(i,J)) / (eta_v(i,J,K) - eta_v(i,J,K+1))) + else + pbv%por_face_areaV(i,J,k) = 0.0 ! use calc_por_interface() might be a better choice + endif + A_layer_prev(i,J) = A_layer else - pbv%por_face_areaV(i,J,k) = 0.0 ! use calc_por_interface() might be a better choice + pbv%por_face_areaV(i,J,k) = 1.0 endif - A_layer_prev(i,J) = A_layer - endif ; enddo ; enddo ; enddo + enddo ; enddo ; enddo endif if (CS%debug) then @@ -231,10 +239,14 @@ subroutine porous_widths_interface(h, tv, G, GV, US, pbv, CS, eta_bt) eta_u(I,j,K), pbv%por_layer_widthU(I,j,K), do_I(I,j)) endif ; enddo ; enddo ; enddo else - do K=1,nk+1 ; do j=js,je ; do I=Isq,Ieq ; if (do_I(I,j)) then - call calc_por_interface(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & - eta_u(I,j,K), pbv%por_layer_widthU(I,j,K), do_I(I,j)) - endif ; enddo ; enddo ; enddo + do K=1,nk+1 ; do j=js,je ; do I=Isq,Ieq + if (do_I(I,j)) then + call calc_por_interface(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), pbv%por_layer_widthU(I,j,K), do_I(I,j)) + else + pbv%por_layer_widthU(I,j,K) = 1.0 + endif + enddo ; enddo ; enddo endif ! v-points @@ -249,10 +261,14 @@ subroutine porous_widths_interface(h, tv, G, GV, US, pbv, CS, eta_bt) eta_v(i,J,K), pbv%por_layer_widthV(i,J,K), do_I(i,J)) endif ; enddo ; enddo ; enddo else - do K=1,nk+1 ; do J=Jsq,Jeq ; do i=is,ie ; if (do_I(i,J)) then - call calc_por_interface(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & - eta_v(i,J,K), pbv%por_layer_widthV(i,J,K), do_I(i,J)) - endif ; enddo ; enddo ; enddo + do K=1,nk+1 ; do J=Jsq,Jeq ; do i=is,ie + if (do_I(i,J)) then + call calc_por_interface(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), pbv%por_layer_widthV(i,J,K), do_I(i,J)) + else + pbv%por_layer_widthV(i,J,K) = 1.0 + endif + enddo ; enddo ; enddo endif if (CS%debug) then diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 2510ff95a5..65e915705a 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -31,11 +31,11 @@ module MOM_variables !> A structure for creating arrays of pointers to 3D arrays type, public :: p3d - real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array [various] end type p3d !> A structure for creating arrays of pointers to 2D arrays type, public :: p2d - real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array [various] end type p2d !> Pointers to various fields which may be used describe the surface state of MOM, and which @@ -323,7 +323,6 @@ module MOM_variables end type BT_cont_type !> Container for grids modifying cell metric at porous barriers -! TODO: rename porous_barrier_type to porous_barrier_type type, public :: porous_barrier_type ! Each of the following fields has nz layers. real, allocatable :: por_face_areaU(:,:,:) !< fractional open area of U-faces [nondim] @@ -339,14 +338,14 @@ module MOM_variables !! the ocean model. Unused fields are unallocated. subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & gas_fields_ocn, use_meltpot, use_iceshelves, & - omit_frazil) + omit_frazil, sfc_state_in, turns) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. logical, optional, intent(in) :: do_integrals !< If true, allocate the space for vertically !! integrated fields. type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the ocean + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate !! in the calculation of additional gas or other !! tracer fluxes, and can be used to spawn related @@ -356,9 +355,20 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & !! under ice shelves. logical, optional, intent(in) :: omit_frazil !< If present and false, do not allocate the space to !! pass frazil fluxes to the coupler + type(surface), & + optional, intent(in) :: sfc_state_in !< If present and its tr_fields are initialized, + !! this type describes the ocean and surface-ice fields that + !! will participate in the calculation of additional gas or + !! other tracer fluxes, and can be used to spawn related + !! internal variables in the ice model. If gas_fields_ocn + !! is present, it is used and tr_fields_in is ignored. + integer, optional, intent(in) :: turns !< If present, the number of counterclockwise quarter + !! turns to use on the new grid. ! local variables logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil + logical :: even_turns ! True if turns is absent or even + integer :: tr_field_i_mem(4), tr_field_j_mem(4) integer :: is, ie, js, je, isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB @@ -406,9 +416,22 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & allocate(sfc_state%tauy_shelf(isd:ied,JsdB:JedB), source=0.0) endif - if (present(gas_fields_ocn)) & + ! The data fields in the coupler_2d_bc_type are never rotated. + even_turns = .true. ; if (present(turns)) even_turns = (modulo(turns, 2) == 0) + if (even_turns) then + tr_field_i_mem(1:4) = (/is,is,ie,ie/) ; tr_field_j_mem(1:4) = (/js,js,je,je/) + else + tr_field_i_mem(1:4) = (/js,js,je,je/) ; tr_field_j_mem(1:4) = (/is,is,ie,ie/) + endif + if (present(gas_fields_ocn)) then call coupler_type_spawn(gas_fields_ocn, sfc_state%tr_fields, & - (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + tr_field_i_mem, tr_field_j_mem, as_needed=.true.) + elseif (present(sfc_state_in)) then + if (coupler_type_initialized(sfc_state_in%tr_fields)) then + call coupler_type_spawn(sfc_state_in%tr_fields, sfc_state%tr_fields, & + tr_field_i_mem, tr_field_j_mem, as_needed=.true.) + endif + endif sfc_state%arrays_allocated = .true. @@ -439,10 +462,10 @@ end subroutine deallocate_surface_state !> Rotate the surface state fields from the input to the model indices. subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) - type(surface), intent(in) :: sfc_state_in - type(surface), intent(inout) :: sfc_state - type(ocean_grid_type), intent(in) :: G - integer, intent(in) :: turns + type(surface), intent(in) :: sfc_state_in !< The input unrotated surface state type that is the data source. + type(surface), intent(inout) :: sfc_state !< The rotated surface state type whose arrays will be filled in + type(ocean_grid_type), intent(in) :: G !< The ocean grid structure + integer, intent(in) :: turns !< The number of counterclockwise quarter turns to use on the rotated grid. logical :: use_temperature, do_integrals, use_melt_potential, use_iceshelves @@ -455,13 +478,9 @@ subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) .and. allocated(sfc_state_in%tauy_shelf) if (.not. sfc_state%arrays_allocated) then - call allocate_surface_state(sfc_state, G, & - use_temperature=use_temperature, & - do_integrals=do_integrals, & - use_meltpot=use_melt_potential, & - use_iceshelves=use_iceshelves & - ) - sfc_state%arrays_allocated = .true. + call allocate_surface_state(sfc_state, G, use_temperature=use_temperature, & + do_integrals=do_integrals, use_meltpot=use_melt_potential, & + use_iceshelves=use_iceshelves, sfc_state_in=sfc_state_in, turns=turns) endif if (use_temperature) then @@ -577,15 +596,15 @@ subroutine MOM_thermovar_chksum(mesg, tv, G, US) ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. if (associated(tv%T)) & - call hchksum(tv%T, mesg//" tv%T", G%HI, scale=US%C_to_degC) + call hchksum(tv%T, mesg//" tv%T", G%HI, unscale=US%C_to_degC) if (associated(tv%S)) & - call hchksum(tv%S, mesg//" tv%S", G%HI, scale=US%S_to_ppt) + call hchksum(tv%S, mesg//" tv%S", G%HI, unscale=US%S_to_ppt) if (associated(tv%frazil)) & - call hchksum(tv%frazil, mesg//" tv%frazil", G%HI, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + call hchksum(tv%frazil, mesg//" tv%frazil", G%HI, unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (associated(tv%salt_deficit)) & - call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, scale=US%RZ_to_kg_m2*US%S_to_ppt) + call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, unscale=US%RZ_to_kg_m2*US%S_to_ppt) if (associated(tv%TempxPmE)) & - call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, scale=US%RZ_to_kg_m2*US%C_to_degC) + call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, unscale=US%RZ_to_kg_m2*US%C_to_degC) end subroutine MOM_thermovar_chksum end module MOM_variables diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index ab3c104d0f..30f080382c 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -121,11 +121,11 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st do_k(:) = .false. ! Open up the file for output if this is the first call. - if (CS%u_file < 0) then + if (CS%u_file == -1) then if (len_trim(CS%u_trunc_file) < 1) return call open_ASCII_file(CS%u_file, trim(CS%u_trunc_file), action=APPEND_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) - if (CS%u_file < 0) then + if (CS%u_file == -1) then call MOM_error(NOTE, 'Unable to open file '//trim(CS%u_trunc_file)//'.') return endif @@ -462,11 +462,11 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st do_k(:) = .false. ! Open up the file for output if this is the first call. - if (CS%v_file < 0) then + if (CS%v_file == -1) then if (len_trim(CS%v_trunc_file) < 1) return call open_ASCII_file(CS%v_file, trim(CS%v_trunc_file), action=APPEND_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) - if (CS%v_file < 0) then + if (CS%v_file == -1) then call MOM_error(NOTE, 'Unable to open file '//trim(CS%v_trunc_file)//'.') return endif diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 15e555ee37..f454ac8d4a 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -25,6 +25,7 @@ module MOM_debugging public :: vec_chksum, vec_chksum_C, vec_chksum_B, vec_chksum_A public :: MOM_debugging_init, totalStuff, totalTandS public :: check_column_integral, check_column_integrals +public :: query_debugging_checks ! These interfaces come from MOM_checksums. public :: hchksum, Bchksum, qchksum, is_NaN, chksum, uvchksum, hchksum_pair @@ -100,6 +101,18 @@ subroutine MOM_debugging_init(param_file) end subroutine MOM_debugging_init +!> Returns logicals indicating which debugging checks should be performed. +subroutine query_debugging_checks(do_debug, do_chksums, do_redundant) + logical, optional, intent(out) :: do_debug !< True if verbose debugging is to be output + logical, optional, intent(out) :: do_chksums !< True if checksums are to be output + logical, optional, intent(out) :: do_redundant !< True if redundant points are to be checked + + if (present(do_debug)) do_debug = debug + if (present(do_chksums)) do_chksums = debug_chksums + if (present(do_redundant)) do_redundant = debug_redundant + +end subroutine query_debugging_checks + !> Check for consistency between the duplicated points of a 3-D C-grid vector subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction, unscale) diff --git a/src/diagnostics/MOM_diagnose_MLD.F90 b/src/diagnostics/MOM_diagnose_MLD.F90 new file mode 100644 index 0000000000..29b66ef6ac --- /dev/null +++ b/src/diagnostics/MOM_diagnose_MLD.F90 @@ -0,0 +1,487 @@ +!> Provides functions for some diabatic processes such as fraxil, brine rejection, +!! tendency due to surface flux divergence. +module MOM_diagnose_mld + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : post_data +use MOM_diag_mediator, only : diag_ctrl +use MOM_EOS, only : calculate_density, calculate_TFreeze, EOS_domain +use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density_derivs +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public diagnoseMLDbyEnergy, diagnoseMLDbyDensityDifference + +! 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 +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains +!> Diagnose a mixed layer depth (MLD) determined by a given density difference with the surface. +!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. +subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, & + ref_h_mld, id_ref_z, id_ref_rho, id_N2subML, id_MLDsq, dz_subML) + type(ocean_grid_type), intent(in) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: id_MLD !< Handle (ID) of MLD diagnostic + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, intent(in) :: densityDiff !< Density difference to determine MLD [R ~> kg m-3] + type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure + real, intent(in) :: ref_h_mld !< Depth of the calculated "surface" densisty [Z ~> m] + integer, intent(in) :: id_ref_z !< Handle (ID) of reference depth diagnostic + integer, intent(in) :: id_ref_rho !< Handle (ID) of reference density diagnostic + integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification + integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD + real, optional, intent(in) :: dz_subML !< The distance over which to calculate N2subML + !! or 50 m if missing [Z ~> m] + + ! Local variables + real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. + real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: hRef_MLD ! Reference depth [Z ~> m]. + real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m or kg m-2] + real, dimension(SZI_(G)) :: dZ_N2 ! Summed vertical distance used in N2 calculation [Z ~> m] + real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [C ~> degC]. + real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [S ~> ppt]. + real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)) :: dZ_2d ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G)) :: dZ, dZm1 ! Layer thicknesses associated with interfaces [Z ~> m] + real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixed layer depth [R ~> kg m-3]. + real, dimension(SZI_(G), SZJ_(G)) :: z_ref_diag ! The actual depth of the reference density [Z ~> m]. + real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. + real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. + real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. + logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 + ! have been stored already. + real :: gE_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq + ! reference density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. + real :: dZ_sub_ML ! Depth below ML over which to diagnose stratification [Z ~> m] + real :: aFac ! A nondimensional factor [nondim] + real :: ddRho ! A density difference [R ~> kg m-3] + real :: dddpth ! A depth difference [Z ~> m] + real :: rhoSurf_k, rhoSurf_km1 ! Desisty in the layers below and above the target reference depth [R ~> kg m-3]. + real, dimension(SZI_(G), SZJ_(G)) :: rhoSurf_2d ! The density that is considered the "surface" when calculating + ! the MLD. It can be saved as a diagnostic [R ~> kg m-3]. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ + + id_SQ = -1 ; if (PRESENT(id_MLDsq)) id_SQ = id_MLDsq + + id_N2 = -1 + if (present(id_N2subML)) then + if (present(dz_subML)) then + id_N2 = id_N2subML + dZ_sub_ML = dz_subML + else + call MOM_error(FATAL, "When the diagnostic of the subML stratification is "//& + "requested by providing id_N2_subML to diagnoseMLDbyDensityDifference, "//& + "the distance over which to calculate that distance must also be provided.") + endif + endif + + gE_rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + hRef_MLD(:) = ref_h_mld + pRef_MLD(:) = GV%H_to_RZ*GV%g_Earth*ref_h_mld + z_ref_diag(:,:) = 0. + + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dZ_2d, j, G, GV) + + if (pRef_MLD(is) /= 0.0) then + rhoSurf(:) = 0.0 + do i=is,ie + dZ(i) = 0.5 * dZ_2d(i,1) ! Depth of center of surface layer + if (dZ(i) >= hRef_MLD(i)) then + call calculate_density(tv%T(i,j,1), tv%S(i,j,1), pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + rhoSurf(i) = rhoSurf_k + endif + enddo + do k=2,nz + do i=is,ie + dZm1(i) = dZ(i) ! Depth of center of layer K-1 + dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K + dddpth = dZ(i) - dZm1(i) + if ((rhoSurf(i) == 0.) .and. & + (dZm1(i) < hRef_MLD(i)) .and. (dZ(i) >= hRef_MLD(i))) then + aFac = ( hRef_MLD(i) - dZm1(i) ) / dddpth + z_ref_diag(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) + call calculate_density(tv%T(i,j,k) , tv%S(i,j,k) , pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + call calculate_density(tv%T(i,j,k-1), tv%S(i,j,k-1), pRef_MLD(i), rhoSurf_km1, tv%eqn_of_state) + rhoSurf(i) = (rhoSurf_k * aFac + rhoSurf_km1 * (1. - aFac)) + H_subML(i) = h(i,j,k) + elseif ((rhoSurf(i) == 0.) .and. (k >= nz)) then + call calculate_density(tv%T(i,j,1), tv%S(i,j,1), pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + rhoSurf(i) = rhoSurf_k + endif + enddo + enddo + do i=is,ie + dZ(i) = 0.5 * dZ_2d(i,1) ! reset dZ to surface depth + rhoSurf_2d(i,j) = rhoSurf(i) + deltaRhoAtK(i) = 0. + MLD(i,j) = 0. + if (id_N2>0) then + subMLN2(i,j) = 0.0 + dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. + endif + enddo + elseif (pRef_MLD(is) == 0.0) then + rhoSurf(:) = 0.0 + do i=is,ie ; dZ(i) = 0.5 * dZ_2d(i,1) ; enddo ! Depth of center of surface layer + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) + do i=is,ie + rhoSurf_2d(i,j) = rhoSurf(i) + deltaRhoAtK(i) = 0. + MLD(i,j) = 0. + if (id_N2>0) then + subMLN2(i,j) = 0.0 + H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. + endif + enddo + endif + + do k=2,nz + do i=is,ie + dZm1(i) = dZ(i) ! Depth of center of layer K-1 + dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K + enddo + + ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding + ! the cells that extend over at least dz_subML. + if (id_N2>0) then + do i=is,ie + if (MLD(i,j) == 0.0) then ! Still in the mixed layer. + H_subML(i) = H_subML(i) + h(i,j,k) + elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. + if (dZ_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML + T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) + H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. + dH_N2(i) = 0.5 * h(i,j,k) + dZ_N2(i) = 0.5 * dz_2d(i,k) + elseif (dZ_N2(i) + dZ_2d(i,k) < dZ_sub_ML) then + dH_N2(i) = dH_N2(i) + h(i,j,k) + dZ_N2(i) = dZ_N2(i) + dz_2d(i,k) + else ! This layer includes the base of the region where N2 is calculated. + T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) + dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) + dZ_N2(i) = dZ_N2(i) + 0.5 * dz_2d(i,k) + N2_region_set(i) = .true. + endif + endif + enddo ! i-loop + endif ! id_N2>0 + + ! Mixed-layer depth, using sigma-0 (surface reference pressure) + do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) + do i = is, ie + deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface + ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) + if ((MLD(i,j) == 0.) .and. (ddRho > 0.) .and. & + (deltaRhoAtKm1(i) < densityDiff) .and. (deltaRhoAtK(i) >= densityDiff)) then + aFac = ( densityDiff - deltaRhoAtKm1(i) ) / ddRho + MLD(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) + endif + if (id_SQ > 0) MLD2(i,j) = MLD(i,j)**2 + enddo ! i-loop + enddo ! k-loop + do i=is,ie + if ((MLD(i,j) == 0.) .and. (deltaRhoAtK(i) < densityDiff)) MLD(i,j) = dZ(i) ! Mixing goes to the bottom + enddo + + if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. + do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo + ! if ((.not.N2_region_set(i)) .and. (dZ_N2(i) > 0.5*dZ_sub_ML)) then + ! ! Use whatever stratification we can, measured over whatever distance is available? + ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) + ! N2_region_set(i) = .true. + ! endif + call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, EOSdom) + call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, EOSdom) + do i=is,ie ; if ((G%mask2dT(i,j) > 0.0) .and. N2_region_set(i)) then + subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / dH_N2(i) + endif ; enddo + endif + enddo ! j-loop + + if (id_MLD > 0) call post_data(id_MLD, MLD, diagPtr) + if (id_N2 > 0) call post_data(id_N2, subMLN2, diagPtr) + if (id_SQ > 0) call post_data(id_SQ, MLD2, diagPtr) + + if ((id_ref_z > 0) .and. (pRef_MLD(is)/=0.)) call post_data(id_ref_z, z_ref_diag , diagPtr) + if (id_ref_rho > 0) call post_data(id_ref_rho, rhoSurf_2d , diagPtr) + +end subroutine diagnoseMLDbyDensityDifference + +!> Diagnose a mixed layer depth (MLD) determined by the depth a given energy value would mix. +!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. +subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) + ! Author: Brandon Reichl + ! Date: October 2, 2020 + ! // + ! *Note that gravity is assumed constant everywhere and divided out of all calculations. + ! + ! This code has been written to step through the columns layer by layer, summing the PE + ! change inferred by mixing the layer with all layers above. When the change exceeds a + ! threshold (determined by input array Mixing_Energy), the code needs to solve for how far + ! into this layer the threshold PE change occurs (assuming constant density layers). + ! This is expressed here via solving the function F(X) = 0 where: + ! F(X) = 0.5 * ( Ca*X^3/(D1+X) + Cb*X^2/(D1+X) + Cc*X/(D1+X) + Dc/(D1+X) + ! + Ca2*X^2 + Cb2*X + Cc2) + ! where all coefficients are determined by the previous mixed layer depth, the + ! density of the previous mixed layer, the present layer thickness, and the present + ! layer density. This equation is worked out by computing the total PE assuming constant + ! density in the mixed layer as well as in the remaining part of the present layer that is + ! not mixed. + ! To solve for X in this equation a Newton's method iteration is employed, which + ! converges extremely quickly (usually 1 guess) since this equation turns out to be rather + ! linear for PE change with increasing X. + ! Input parameters: + integer, dimension(3), intent(in) :: id_MLD !< Energy output diagnostic IDs + type(ocean_grid_type), intent(in) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 3 MLDs [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),3) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. + real, dimension(SZK_(GV)+1) :: Z_int ! Depths of the interfaces from the surface [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: dZ ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: Rho_c ! Columns of layer densities [R ~> kg m-3] + real, dimension(SZI_(G)) :: pRef_MLD ! The reference pressure for the mixed layer + ! depth calculation [R L2 T-2 ~> Pa] + real, dimension(3) :: PE_threshold ! The energy threshold divided by g [R Z2 ~> kg m-1] + + real :: PE_Threshold_fraction ! The fractional tolerance of the specified energy + ! for the energy used to mix to the diagnosed depth [nondim] + real :: H_ML ! The accumulated depth of the mixed layer [Z ~> m] + real :: PE ! The cumulative potential energy of the unmixed water column to a depth + ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: PE_Mixed ! The potential energy of the completely mixed water column to a depth + ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: RhoDZ_ML ! The depth integrated density of the mixed layer [R Z ~> kg m-2] + real :: H_ML_TST ! A new test value for the depth of the mixed layer [Z ~> m] + real :: PE_Mixed_TST ! The potential energy of the completely mixed water column to a depth + ! of H_ML_TST, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: RhoDZ_ML_TST ! A test value of the new depth integrated density of the mixed layer [R Z ~> kg m-2] + real :: Rho_ML ! The average density of the mixed layer [R ~> kg m-3] + + ! These are all temporary variables used to shorten the expressions in the iterations. + real :: R1, R2, Ca, Ca2 ! Some densities [R ~> kg m-3] + real :: D1, D2, X, X2 ! Some thicknesses [Z ~> m] + real :: Cb, Cb2 ! A depth integrated density [R Z ~> kg m-2] + real :: C, D ! A depth squared [Z2 ~> m2] + real :: Cc, Cc2 ! A density times a depth squared [R Z2 ~> kg m-1] + real :: Cd ! A density times a depth cubed [R Z3 ~> kg] + real :: Gx ! A triple integral in depth of density [R Z3 ~> kg] + real :: Gpx ! The derivative of Gx with x [R Z2 ~> kg m-1] + real :: Hx ! The vertical integral depth [Z ~> m] + real :: iHx ! The inverse of Hx [Z-1 ~> m-1] + real :: Hpx ! The derivative of Hx with x, hard coded to 1. Why? [nondim] + real :: Ix ! A double integral in depth of density [R Z2 ~> kg m-1] + real :: Ipx ! The derivative of Ix with x [R Z ~> kg m-2] + real :: Fgx ! The mixing energy difference from the target [R Z2 ~> kg m-1] + real :: Fpx ! The derivative of Fgx with x [R Z ~> kg m-2] + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: IT, iM + integer :: i, j, is, ie, js, je, k, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + pRef_MLD(:) = 0.0 + mld(:,:,:) = 0.0 + PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. + + do iM=1,3 + PE_threshold(iM) = Mixing_Energy(iM) / (US%L_to_Z**2*GV%g_Earth) + enddo + + MLD(:,:,:) = 0.0 + + EOSdom(:) = EOS_domain(G%HI) + + do j=js,je + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do k=1,nz + call calculate_density(tv%T(:,j,k), tv%S(:,j,K), pRef_MLD, rho_c(:,k), tv%eqn_of_state, EOSdom) + enddo + + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + + Z_int(1) = 0.0 + do k=1,nz + Z_int(K+1) = Z_int(K) - dZ(i,k) + enddo + + do iM=1,3 + + ! Initialize these for each column-wise calculation + PE = 0.0 + RhoDZ_ML = 0.0 + H_ML = 0.0 + RhoDZ_ML_TST = 0.0 + H_ML_TST = 0.0 + PE_Mixed = 0.0 + + do k=1,nz + + ! This is the unmixed PE cumulative sum from top down + PE = PE + 0.5 * Rho_c(i,k) * (Z_int(K)**2 - Z_int(K+1)**2) + + ! This is the depth and integral of density + H_ML_TST = H_ML + dZ(i,k) + RhoDZ_ML_TST = RhoDZ_ML + Rho_c(i,k) * dZ(i,k) + + ! The average density assuming all layers including this were mixed + Rho_ML = RhoDZ_ML_TST/H_ML_TST + + ! The PE assuming all layers including this were mixed + ! Note that 0. could be replaced with "Surface", which doesn't have to be 0 + ! but 0 is a good reference value. + PE_Mixed_TST = 0.5 * Rho_ML * (0.**2 - (0. - H_ML_TST)**2) + + ! Check if we supplied enough energy to mix to this layer + if (PE_Mixed_TST - PE <= PE_threshold(iM)) then + H_ML = H_ML_TST + RhoDZ_ML = RhoDZ_ML_TST + + else ! If not, we need to solve where the energy ran out + ! This will be done with a Newton's method iteration: + + R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) + D1 = H_ML ! The thickness of the mixed layer (not including this layer) + R2 = Rho_c(i,k) ! The density of this layer + D2 = dZ(i,k) ! The thickness of this layer + + ! This block could be used to calculate the function coefficients if + ! we don't reference all values to a surface designated as z=0 + ! S = Surface + ! Ca = -(R2) + ! Cb = -( (R1*D1) + R2*(2.*D1-2.*S) ) + ! D = D1**2. - 2.*D1*S + ! Cc = -( R1*D1*(2.*D1-2.*S) + R2*D ) + ! Cd = -(R1*D1*D) + ! Ca2 = R2 + ! Cb2 = R2*(2*D1-2*S) + ! C = S**2 + D2**2 + D1**2 - 2*D1*S - 2.*D2*S +2.*D1*D2 + ! Cc2 = R2*(D+S**2-C) + ! + ! If the surface is S = 0, it simplifies to: + Ca = -R2 + Cb = -(R1 * D1 + R2 * (2. * D1)) + D = D1**2 + Cc = -(R1 * D1 * (2. * D1) + (R2 * D)) + Cd = -R1 * (D1 * D) + Ca2 = R2 + Cb2 = R2 * (2. * D1) + C = D2**2 + D1**2 + 2. * (D1 * D2) + Cc2 = R2 * (D - C) + + ! First guess for an iteration using Newton's method + X = dZ(i,k) * 0.5 + + IT=0 + do while(IT<10)!We can iterate up to 10 times + ! We are trying to solve the function: + ! F(x) = G(x)/H(x)+I(x) + ! for where F(x) = PE+PE_threshold, or equivalently for where + ! F(x) = G(x)/H(x)+I(x) - (PE+PE_threshold) = 0 + ! We also need the derivative of this function for the Newton's method iteration + ! F'(x) = (G'(x)H(x)-G(x)H'(x))/H(x)^2 + I'(x) + ! G and its derivative + Gx = 0.5 * (Ca * (X*X*X) + Cb * X**2 + Cc * X + Cd) + Gpx = 0.5 * (3. * (Ca * X**2) + 2. * (Cb * X) + Cc) + ! H, its inverse, and its derivative + Hx = D1 + X + iHx = 1. / Hx + Hpx = 1. + ! I and its derivative + Ix = 0.5 * (Ca2 * X**2 + Cb2 * X + Cc2) + Ipx = 0.5 * (2. * Ca2 * X + Cb2) + + ! The Function and its derivative: + PE_Mixed = Gx * iHx + Ix + Fgx = PE_Mixed - (PE + PE_threshold(iM)) + Fpx = (Gpx * Hx - Hpx * Gx) * iHx**2 + Ipx + + ! Check if our solution is within the threshold bounds, if not update + ! using Newton's method. This appears to converge almost always in + ! one step because the function is very close to linear in most applications. + if (abs(Fgx) > PE_Threshold(iM) * PE_Threshold_fraction) then + X2 = X - Fgx / Fpx + IT = IT + 1 + if (X2 < 0. .or. X2 > dZ(i,k)) then + ! The iteration seems to be robust, but we need to do something *if* + ! things go wrong... How should we treat failed iteration? + ! Present solution: Stop trying to compute and just say we can't mix this layer. + X=0 + exit + else + X = X2 + endif + else + exit! Quit the iteration + endif + enddo + H_ML = H_ML + X + exit! Quit looping through the column + endif + enddo + MLD(i,j,iM) = H_ML + enddo + endif ; enddo + enddo + + if (id_MLD(1) > 0) call post_data(id_MLD(1), MLD(:,:,1), diagPtr) + if (id_MLD(2) > 0) call post_data(id_MLD(2), MLD(:,:,2), diagPtr) + if (id_MLD(3) > 0) call post_data(id_MLD(3), MLD(:,:,3), diagPtr) + +end subroutine diagnoseMLDbyEnergy + +!> \namespace mom_diagnose_mld +!! +!! This module contains subroutines that apply various diabatic processes. Usually these +!! subroutines are called from the MOM_diabatic module. All of these routines use appropriate +!! limiters or logic to work properly with arbitrary layer thicknesses (including massless layers) +!! and an arbitrarily large timestep. +!! +!! The subroutine diagnoseMLDbyDensityDifference diagnoses a mixed layer depth based on a +!! density difference criterion, and may also estimate the stratification of the water below +!! this diagnosed mixed layer. +!! +!! The subroutine diagnoseMLDbyEnergy diagnoses a mixed layer depth based on a mixing-energy +!! criterion, as described by Reichl et al., 2022, JGR: Oceans, doi:10.1029/2021JC018140. +!! + +end module MOM_diagnose_mld diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 3376dc9be8..677fdfe6dc 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -970,9 +970,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (.not.(CS%KE_term_on .or. (CS%id_KE > 0))) return - do j=js-1,je ; do i=is-1,ie - KE_u(I,j) = 0.0 ; KE_v(i,J) = 0.0 - enddo ; enddo + KE_u(:,:) = 0. ; KE_v(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie KE(i,j,k) = (((u(I,j,k) * u(I,j,k)) + (u(I-1,j,k) * u(I-1,j,k))) & @@ -1377,7 +1375,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = G%mask2dT(i,j) * (ssh(i,j) + G%bathyT(i,j)) enddo ; enddo - volo = global_area_integral(work_2d, G, scale=US%Z_to_m) + volo = global_area_integral(work_2d, G, unscale=US%Z_to_m) call post_data(IDs%id_volo, volo, diag) endif @@ -1580,6 +1578,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag logical :: better_speed_est ! If true, use a more robust estimate of the first ! mode wave speed as the starting point for iterations. logical :: split ! True if using the barotropic-baroclinic split algorithm + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. @@ -1617,6 +1616,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & "If true, use a more robust estimate of the first mode wave speed as the "//& "starting point for iterations.", default=.true.) + call get_param(param_file, mdl, "INTWAVE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -1856,9 +1859,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag if ((CS%id_cg1>0) .or. (CS%id_Rd1>0) .or. (CS%id_cfl_cg1>0) .or. & (CS%id_cfl_cg1_x>0) .or. (CS%id_cfl_cg1_y>0) .or. & (CS%id_cg_ebt>0) .or. (CS%id_Rd_ebt>0) .or. (CS%id_p_ebt>0)) then - call wave_speed_init(CS%wave_speed, remap_answer_date=remap_answer_date, & + call wave_speed_init(CS%wave_speed, GV, remap_answer_date=remap_answer_date, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & - wave_speed_tol=wave_speed_tol) + wave_speed_tol=wave_speed_tol, om4_remap_via_sub_cells=om4_remap_via_sub_cells) endif CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, & diff --git a/src/diagnostics/MOM_harmonic_analysis.F90 b/src/diagnostics/MOM_harmonic_analysis.F90 new file mode 100644 index 0000000000..1e3b9895cb --- /dev/null +++ b/src/diagnostics/MOM_harmonic_analysis.F90 @@ -0,0 +1,454 @@ +!> Inline harmonic analysis (conventional) +module MOM_harmonic_analysis + +use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, get_date, increment_date, & + operator(+), operator(-), operator(<), operator(>), operator(>=) +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_file_parser, only : param_file_type, get_param +use MOM_io, only : file_exists, open_ASCII_file, READONLY_FILE, close_file, & + MOM_infra_file, vardesc, MOM_field, & + var_desc, create_MOM_file, SINGLE_FILE, MOM_write_field +use MOM_error_handler, only : MOM_mesg, MOM_error, NOTE + +implicit none ; private + +public HA_init, HA_register, HA_accum_FtF, HA_accum_FtSSH + +#include + +integer, parameter :: MAX_CONSTITUENTS = 10 !< The maximum number of tidal constituents + +!> The private control structure for storing the HA info of a particular field +type, private :: HA_type + character(len=16) :: key = "none" !< Name of the field of which harmonic analysis is to be performed + character(len=1) :: grid !< The grid on which the field is defined ('h', 'q', 'u', or 'v') + real :: old_time = -1.0 !< The time of the previous accumulating step [T ~> s] + real, allocatable :: ref(:,:) !< The initial field in arbitrary units [A] + real, allocatable :: FtSSH(:,:,:) !< Accumulator of (F' * SSH_in) in arbitrary units [A] + !>@{ Lower and upper bounds of input data + integer :: is, ie, js, je + !>@} +end type HA_type + +!> A linked list of control structures that store the HA info of different fields +type, private :: HA_node + type(HA_type) :: this !< Control structure of the current field in the list + type(HA_node), pointer :: next !< The list of other fields +end type HA_node + +!> The public control structure of the MOM_harmonic_analysis module +type, public :: harmonic_analysis_CS ; private + logical :: HAready = .false. !< If true, perform harmonic analysis + type(time_type) :: & + time_start, & !< Start time of harmonic analysis + time_end, & !< End time of harmonic analysis + time_ref !< Reference time (t = 0) used to calculate tidal forcing + real, dimension(MAX_CONSTITUENTS) :: & + freq, & !< The frequency of a tidal constituent [T-1 ~> s-1] + phase0 !< The phase of a tidal constituent at time 0 [rad] + real, allocatable :: FtF(:,:) !< Accumulator of (F' * F) for all fields [nondim] + integer :: nc !< The number of tidal constituents in use + integer :: length !< Number of fields of which harmonic analysis is to be performed + character(len=16) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent + character(len=255) :: path !< Path to directory where output will be written + type(unit_scale_type) :: US !< A dimensional unit scaling type + type(HA_node), pointer :: list => NULL() !< A linked list for storing the HA info of different fields +end type harmonic_analysis_CS + +contains + +!> This subroutine sets static variables used by this module and initializes CS%list. +!! THIS MUST BE CALLED AT THE END OF tidal_forcing_init. +subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name, CS) + type(time_type), intent(in) :: Time !< The current model time + type(time_type), intent(in) :: time_ref !< Reference time (t = 0) used to calculate tidal forcing + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + real, dimension(MAX_CONSTITUENTS), intent(in) :: freq !< The frequency of a tidal constituent [T-1 ~> s-1] + real, dimension(MAX_CONSTITUENTS), intent(in) :: phase0 !< The phase of a tidal constituent at time 0 [rad] + integer, intent(in) :: nc !< The number of tidal constituents in use + character(len=16), intent(in) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent + type(harmonic_analysis_CS), intent(out) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + type(HA_type) :: ha1 !< A temporary, null field used for initializing CS%list + real :: HA_start_time !< Start time of harmonic analysis [T ~> s] + real :: HA_end_time !< End time of harmonic analysis [T ~> s] + character(len=40) :: mdl="MOM_harmonic_analysis" !< This module's name + character(len=255) :: mesg + integer :: year, month, day, hour, minute, second + + ! Determine CS%time_start and CS%time_end + call get_param(param_file, mdl, "HA_START_TIME", HA_start_time, & + "Start time of harmonic analysis, in units of days after "//& + "the start of the current run segment. Must be smaller than "//& + "HA_END_TIME, otherwise harmonic analysis will not be performed. "//& + "If negative, |HA_START_TIME| determines the length of harmonic analysis, "//& + "and harmonic analysis will start |HA_START_TIME| days before HA_END_TIME, "//& + "or at the beginning of the run segment, whichever occurs later.", & + units="days", default=0.0, scale=86400.0*US%s_to_T) + call get_param(param_file, mdl, "HA_END_TIME", HA_end_time, & + "End time of harmonic analysis, in units of days after "//& + "the start of the current run segment. Must be positive "//& + "and smaller than the length of the currnet run segment, "//& + "otherwise harmonic analysis will not be performed.", & + units="days", default=0.0, scale=86400.0*US%s_to_T) + + if (HA_end_time <= 0.0) then + call MOM_mesg('MOM_harmonic_analysis: HA_END_TIME is zero or negative. '//& + 'Harmonic analysis will not be performed.') + CS%HAready = .false. ; return + endif + + if (HA_end_time <= HA_start_time) then + call MOM_mesg('MOM_harmonic_analysis: HA_END_TIME is smaller than or equal to HA_START_TIME. '//& + 'Harmonic analysis will not be performed.') + CS%HAready = .false. ; return + endif + + CS%HAready = .true. + + if (HA_start_time < 0.0) then + HA_start_time = HA_end_time + HA_start_time + if (HA_start_time <= 0.0) HA_start_time = 0.0 + endif + + CS%time_start = Time + real_to_time(US%T_to_s * HA_start_time) + CS%time_end = Time + real_to_time(US%T_to_s * HA_end_time) + + call get_date(Time, year, month, day, hour, minute, second) + write(mesg,*) "MOM_harmonic_analysis: run segment starts on ", year, month, day, hour, minute, second + call MOM_error(NOTE, trim(mesg)) + call get_date(CS%time_start, year, month, day, hour, minute, second) + write(mesg,*) "MOM_harmonic_analysis: harmonic analysis starts on ", year, month, day, hour, minute, second + call MOM_error(NOTE, trim(mesg)) + call get_date(CS%time_end, year, month, day, hour, minute, second) + write(mesg,*) "MOM_harmonic_analysis: harmonic analysis ends on ", year, month, day, hour, minute, second + call MOM_error(NOTE, trim(mesg)) + + ! Set path to directory where output will be written + call get_param(param_file, mdl, "HA_PATH", CS%path, & + "Path to output files for runtime harmonic analysis.", default="./") + + ! Populate some parameters of the control structure + CS%time_ref = time_ref + CS%freq = freq + CS%phase0 = phase0 + CS%nc = nc + CS%const_name = const_name + CS%length = 0 + CS%US = US + + allocate(CS%FtF(2*nc+1,2*nc+1), source=0.0) + + ! Initialize CS%list + allocate(CS%list) + CS%list%this = ha1 + nullify(CS%list%next) + +end subroutine HA_init + +!> This subroutine registers each of the fields on which HA is to be performed. +subroutine HA_register(key, grid, CS) + character(len=*), intent(in) :: key !< Name of the current field + character(len=1), intent(in) :: grid !< The grid on which the key field is defined + type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + type(HA_type) :: ha1 !< Control structure for the current field + type(HA_node), pointer :: tmp !< A temporary list to hold the current field + + if (.not. CS%HAready) return + + allocate(tmp) + ha1%key = trim(key) + ha1%grid = trim(grid) + tmp%this = ha1 + tmp%next => CS%list + CS%list => tmp + CS%length = CS%length + 1 + +end subroutine HA_register + +!> This subroutine accumulates the temporal basis functions in FtF. +!! The tidal constituents are those used in MOM_tidal_forcing, plus the mean (of zero frequency). +subroutine HA_accum_FtF(Time, CS) + type(time_type), intent(in) :: Time !< The current model time + type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + real :: now !< The relative time compared with tidal reference [T ~> s] + real :: cosomegat, sinomegat, ccosomegat, ssinomegat !< The components of the phase [nondim] + integer :: nc, c, icos, isin, cc, iccos, issin + + ! Exit the accumulator in the following cases + if (.not. CS%HAready) return + if (CS%length == 0) return + if (Time < CS%time_start) return + if (Time > CS%time_end) return + + nc = CS%nc + now = CS%US%s_to_T * time_type_to_real(Time - CS%time_ref) + + ! Accumulate FtF + CS%FtF(1,1) = CS%FtF(1,1) + 1.0 !< For the zero frequency + do c=1,nc + icos = 2*c + isin = 2*c+1 + cosomegat = cos(CS%freq(c) * now + CS%phase0(c)) + sinomegat = sin(CS%freq(c) * now + CS%phase0(c)) + CS%FtF(icos,1) = CS%FtF(icos,1) + cosomegat + CS%FtF(isin,1) = CS%FtF(isin,1) + sinomegat + CS%FtF(1,icos) = CS%FtF(icos,1) + CS%FtF(1,isin) = CS%FtF(isin,1) + do cc=c,nc + iccos = 2*cc + issin = 2*cc+1 + ccosomegat = cos(CS%freq(cc) * now + CS%phase0(cc)) + ssinomegat = sin(CS%freq(cc) * now + CS%phase0(cc)) + CS%FtF(icos,iccos) = CS%FtF(icos,iccos) + cosomegat * ccosomegat + CS%FtF(icos,issin) = CS%FtF(icos,issin) + cosomegat * ssinomegat + CS%FtF(isin,iccos) = CS%FtF(isin,iccos) + sinomegat * ccosomegat + CS%FtF(isin,issin) = CS%FtF(isin,issin) + sinomegat * ssinomegat + enddo ! cc=c,nc + enddo ! c=1,nc + +end subroutine HA_accum_FtF + +!> This subroutine accumulates the temporal basis functions in FtSSH and then calls HA_write to compute +!! harmonic constants and write results. The tidal constituents are those used in MOM_tidal_forcing, plus the +!! mean (of zero frequency). +subroutine HA_accum_FtSSH(key, data, Time, G, CS) + character(len=*), intent(in) :: key !< Name of the current field + real, dimension(:,:), intent(in) :: data !< Input data of which harmonic analysis is to be performed [A] + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + type(HA_type), pointer :: ha1 + type(HA_node), pointer :: tmp + real :: now !< The relative time compared with the tidal reference [T ~> s] + real :: dt !< The current time step size of the accumulator [T ~> s] + real :: cosomegat, sinomegat !< The components of the phase [nondim] + integer :: nc, i, j, k, c, icos, isin, is, ie, js, je + character(len=128) :: mesg + + ! Exit the accumulator in the following cases + if (.not. CS%HAready) return + if (CS%length == 0) return + if (Time < CS%time_start) return + if (Time > CS%time_end) return + + ! Loop through the full list to find the current field + tmp => CS%list + do k=1,CS%length + ha1 => tmp%this + if (trim(key) == trim(ha1%key)) exit + tmp => tmp%next + if (k == CS%length) return !< Do not perform harmonic analysis of a field that is not registered + enddo + + nc = CS%nc + now = CS%US%s_to_T * time_type_to_real(Time - CS%time_ref) + + ! Additional processing at the initial accumulating step + if (ha1%old_time < 0.0) then + ha1%old_time = now + + write(mesg,*) "MOM_harmonic_analysis: initializing accumulator, key = ", trim(ha1%key) + call MOM_error(NOTE, trim(mesg)) + + ! Get the lower and upper bounds of input data + ha1%is = LBOUND(data,1) ; is = ha1%is + ha1%ie = UBOUND(data,1) ; ie = ha1%ie + ha1%js = LBOUND(data,2) ; js = ha1%js + ha1%je = UBOUND(data,2) ; je = ha1%je + + allocate(ha1%ref(is:ie,js:je), source=0.0) + allocate(ha1%FtSSH(is:ie,js:je,2*nc+1), source=0.0) + ha1%ref(:,:) = data(:,:) + endif + + dt = now - ha1%old_time + ha1%old_time = now !< Keep track of time so we know when Time approaches CS%time_end + + is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je + + ! Accumulate FtF and FtSSH + do c=1,nc + icos = 2*c + isin = 2*c+1 + cosomegat = cos(CS%freq(c) * now + CS%phase0(c)) + sinomegat = sin(CS%freq(c) * now + CS%phase0(c)) + do j=js,je ; do i=is,ie + ha1%FtSSH(i,j,1) = ha1%FtSSH(i,j,1) + (data(i,j) - ha1%ref(i,j)) + ha1%FtSSH(i,j,icos) = ha1%FtSSH(i,j,icos) + (data(i,j) - ha1%ref(i,j)) * cosomegat + ha1%FtSSH(i,j,isin) = ha1%FtSSH(i,j,isin) + (data(i,j) - ha1%ref(i,j)) * sinomegat + enddo ; enddo + enddo ! c=1,nc + + ! Compute harmonic constants and write output as Time approaches CS%time_end + ! This guarantees that HA_write will be called before Time becomes larger than CS%time_end + if (time_type_to_real(CS%time_end - Time) <= dt) then + call HA_write(ha1, Time, G, CS) + + write(mesg,*) "MOM_harmonic_analysis: harmonic analysis done, key = ", trim(ha1%key) + call MOM_error(NOTE, trim(mesg)) + + ! De-register the current field and deallocate memory + ha1%key = 'none' + deallocate(ha1%ref) + deallocate(ha1%FtSSH) + endif + +end subroutine HA_accum_FtSSH + +!> This subroutine computes the harmonic constants and write output for the current field +subroutine HA_write(ha1, Time, G, CS) + type(HA_type), pointer, intent(in) :: ha1 !< Control structure for the current field + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(harmonic_analysis_CS), intent(in) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + real, dimension(:,:,:), allocatable :: FtSSHw !< An array containing the harmonic constants [A] + integer :: year, month, day, hour, minute, second + integer :: nc, k, is, ie, js, je + + character(len=255) :: filename !< Output file name + type(MOM_infra_file) :: cdf !< The file handle for output harmonic constants + type(vardesc), allocatable :: cdf_vars(:) !< Output variable names + type(MOM_field), allocatable :: cdf_fields(:) !< Field type variables for the output fields + + nc = CS%nc ; is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je + + allocate(FtSSHw(is:ie,js:je,2*nc+1), source=0.0) + + ! Compute the harmonic coefficients + call HA_solver(ha1, nc, CS%FtF, FtSSHw) + + ! Output file name + call get_date(Time, year, month, day, hour, minute, second) + write(filename, '(a,"HA_",a,i0.4,i0.2,i0.2,".nc")') & + trim(CS%path), trim(ha1%key), year, month, day + + allocate(cdf_vars(2*nc+1)) + allocate(cdf_fields(2*nc+1)) + + ! Variable names + cdf_vars(1) = var_desc("z0", "m" ,"mean value", ha1%grid, '1', '1') + do k=1,nc + cdf_vars(2*k ) = var_desc(trim(CS%const_name(k))//"cos", "m", "cosine coefficient", ha1%grid, '1', '1') + cdf_vars(2*k+1) = var_desc(trim(CS%const_name(k))//"sin", "m", "sine coefficient", ha1%grid, '1', '1') + enddo + + ! Create output file + call create_MOM_file(cdf, trim(filename), cdf_vars, & + 2*nc+1, cdf_fields, SINGLE_FILE, 86400.0, G=G) + + ! Write data + call MOM_write_field(cdf, cdf_fields(1), G%domain, FtSSHw(:,:,1), 0.0) + do k=1,nc + call MOM_write_field(cdf, cdf_fields(2*k ), G%domain, FtSSHw(:,:,2*k ), 0.0) + call MOM_write_field(cdf, cdf_fields(2*k+1), G%domain, FtSSHw(:,:,2*k+1), 0.0) + enddo + + call cdf%flush() + deallocate(cdf_vars) + deallocate(cdf_fields) + deallocate(FtSSHw) + +end subroutine HA_write + +!> This subroutine computes the harmonic constants (stored in FtSSHw) using the dot products of the temporal +!! basis functions accumulated in FtF, and the dot products of the SSH (or other fields) with the temporal basis +!! functions accumulated in FtSSH. The system is solved by Cholesky decomposition, +!! +!! FtF * FtSSHw = FtSSH, => FtFw * (FtFw' * FtSSHw) = FtSSH, +!! +!! where FtFw is a lower triangular matrix, and the prime denotes matrix transpose. +!! +subroutine HA_solver(ha1, nc, FtF, FtSSHw) + type(HA_type), pointer, intent(in) :: ha1 !< Control structure for the current field + integer, intent(in) :: nc !< Number of harmonic constituents + real, dimension(:,:), intent(in) :: FtF !< Accumulator of (F' * F) for all fields [nondim] + real, dimension(:,:,:), allocatable, intent(out) :: FtSSHw !< Work array for Cholesky decomposition [A] + + ! Local variables + real :: tmp0 !< Temporary variable for Cholesky decomposition [nondim] + real, dimension(:), allocatable :: tmp1 !< Temporary variable for Cholesky decomposition [nondim] + real, dimension(:,:), allocatable :: tmp2 !< Temporary variable for Cholesky decomposition [A] + real, dimension(:,:), allocatable :: FtFw !< Lower triangular matrix for Cholesky decomposition [nondim] + integer :: k, m, n, is, ie, js, je + + is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je + + allocate(tmp1(1:2*nc+1), source=0.0) + allocate(tmp2(is:ie,js:je), source=0.0) + allocate(FtFw(1:2*nc+1,1:2*nc+1), source=0.0) + allocate(FtSSHw(is:ie,js:je,2*nc+1), source=0.0) + + ! Construct FtFw + FtFw(:,:) = 0.0 + do m=1,2*nc+1 + tmp0 = 0.0 + do k=1,m-1 + tmp0 = tmp0 + FtFw(m,k) * FtFw(m,k) + enddo + FtFw(m,m) = sqrt(FtF(m,m) - tmp0) + tmp1(m) = 1 / FtFw(m,m) + do k=m+1,2*nc+1 + tmp0 = 0.0 + do n=1,m-1 + tmp0 = tmp0 + FtFw(k,n) * FtFw(m,n) + enddo + FtFw(k,m) = (FtF(k,m) - tmp0) * tmp1(m) + enddo + enddo + + ! Solve for (FtFw' * FtSSHw) + FtSSHw(:,:,:) = ha1%FtSSH(:,:,:) + do k=1,2*nc+1 + tmp2(:,:) = 0.0 + do m=1,k-1 + tmp2(:,:) = tmp2(:,:) + FtFw(k,m) * FtSSHw(:,:,m) + enddo + FtSSHw(:,:,k) = (FtSSHw(:,:,k) - tmp2(:,:)) * tmp1(k) + enddo + + ! Solve for FtSSHw + do k=2*nc+1,1,-1 + tmp2(:,:) = 0.0 + do m=k+1,2*nc+1 + tmp2(:,:) = tmp2(:,:) + FtSSHw(:,:,m) * FtFw(m,k) + enddo + FtSSHw(:,:,k) = (FtSSHw(:,:,k) - tmp2(:,:)) * tmp1(k) + enddo + + deallocate(tmp1) + deallocate(tmp2) + deallocate(FtFw) + +end subroutine HA_solver + +!> \namespace harmonic_analysis +!! +!! This module computes the harmonic constants which can be used to reconstruct the tidal elevation (or other +!! fields) through SSH = F * x, where F is an nt-by-2*nc matrix (nt is the number of time steps and nc is the +!! number of tidal constituents) containing the cosine/sine functions for each frequency evaluated at each time +!! step, and x is a 2*nc-by-1 vector containing the constant coefficients of the sine/cosine for each constituent +!! (i.e., the harmonic constants). At each grid point, the harmonic constants are computed using least squares, +!! +!! (F' * F) * x = F' * SSH_in, +!! +!! where the prime denotes matrix transpose, and SSH_in is the sea surface height (or other fields) determined by +!! the model. The dot products (F' * F) and (F' * SSH_in) are computed by accumulating the sums as the model is +!! running and stored in the arrays FtF and FtSSH, respectively. The FtF matrix is inverted as needed before +!! computing and writing out the harmonic constants. +!! +!! Ed Zaron and William Xu (chengzhu.xu@oregonstate.edu), April 2024. + +end module MOM_harmonic_analysis + diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index 0d656edf6d..fe33e38a80 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -7,9 +7,11 @@ module MOM_spatial_means use MOM_coms, only : EFP_to_real, real_to_EFP, EFP_sum_across_PEs use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real use MOM_coms, only : query_EFP_overflow_error, reset_EFP_overflow_error +use MOM_coms, only : max_across_PEs, min_across_PEs use MOM_error_handler, only : MOM_error, NOTE, WARNING, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -21,6 +23,7 @@ module MOM_spatial_means public :: global_area_integral public :: global_volume_mean, global_mass_integral, global_mass_int_EFP public :: adjust_area_mean_to_zero +public :: array_global_min_max ! 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 @@ -32,7 +35,7 @@ module MOM_spatial_means contains !> Return the global area mean of a variable. This uses reproducing sums. -function global_area_mean(var, G, scale, tmp_scale) +function global_area_mean(var, G, scale, tmp_scale, unscale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to average in !! arbitrary, possibly rescaled units [A ~> a] @@ -41,6 +44,11 @@ function global_area_mean(var, G, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the variable !! that is reversed in the return value [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. real :: global_area_mean ! The mean of the variable in arbitrary unscaled units [a] or scaled units [A ~> a] ! Local variables @@ -53,7 +61,9 @@ function global_area_mean(var, G, scale, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale + scalefac = G%US%L_to_m**2*temp_scale + if (present(unscale)) then ; scalefac = scalefac * unscale + elseif (present(scale)) then ; scalefac = scalefac * scale ; endif tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie @@ -96,7 +106,7 @@ function global_area_mean_v(var, G, tmp_scale) scalefac = G%US%L_to_m**2*temp_scale tmpForSumming(:,:) = 0. - do J=js,je ; do i=is,ie + do j=js,je ; do i=is,ie tmpForSumming(i,j) = G%areaT(i,j) * scalefac * & (var(i,J) * G%mask2dCv(i,J) + var(i,J-1) * G%mask2dCv(i,J-1)) / & max(1.e-20, G%mask2dCv(i,J)+G%mask2dCv(i,J-1)) @@ -148,7 +158,7 @@ end function global_area_mean_u !> Return the global area integral of a variable, by default using the masked area from the !! grid, but an alternate could be used instead. This uses reproducing sums. -function global_area_integral(var, G, scale, area, tmp_scale) +function global_area_integral(var, G, scale, area, tmp_scale, unscale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to integrate in !! arbitrary, possibly rescaled units [A ~> a] @@ -159,6 +169,11 @@ function global_area_integral(var, G, scale, area, tmp_scale) !! any required masking [L2 ~> m2]. real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the !! variable that is reversed in the return value [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. real :: global_area_integral !< The returned area integral, usually in the units of var times an area, !! [a m2] or [A m2 ~> a m2] depending on which optional arguments are provided @@ -172,7 +187,9 @@ function global_area_integral(var, G, scale, area, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale + scalefac = G%US%L_to_m**2*temp_scale + if (present(unscale)) then ; scalefac = scalefac * unscale + elseif (present(scale)) then ; scalefac = scalefac * scale ; endif tmpForSumming(:,:) = 0. if (present(area)) then @@ -193,7 +210,7 @@ function global_area_integral(var, G, scale, area, tmp_scale) end function global_area_integral !> Return the layerwise global thickness-weighted mean of a variable. This uses reproducing sums. -function global_layer_mean(var, h, G, GV, scale, tmp_scale) +function global_layer_mean(var, h, G, GV, scale, tmp_scale, unscale) 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) :: var !< The variable to average in @@ -204,6 +221,11 @@ function global_layer_mean(var, h, G, GV, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the !! variable that is reversed in the return value [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence. real, dimension(SZK_(GV)) :: global_layer_mean !< The mean of the variable in the arbitrary scaled [A] !! or unscaled [a] units of var, depending on which optional !! arguments are provided @@ -224,7 +246,9 @@ function global_layer_mean(var, h, G, GV, scale, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = temp_scale ; if (present(scale)) scalefac = scale * temp_scale + scalefac = temp_scale + if (present(unscale)) then ; scalefac = unscale * temp_scale + elseif (present(scale)) then ; scalefac = scale * temp_scale ; endif tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie @@ -243,7 +267,7 @@ function global_layer_mean(var, h, G, GV, scale, tmp_scale) end function global_layer_mean !> Find the global thickness-weighted mean of a variable. This uses reproducing sums. -function global_volume_mean(var, h, G, GV, scale, tmp_scale) +function global_volume_mean(var, h, G, GV, scale, tmp_scale, unscale) 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)), & @@ -256,6 +280,11 @@ function global_volume_mean(var, h, G, GV, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the !! variable that is reversed in the return value [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. real :: global_volume_mean !< The thickness-weighted average of var in the arbitrary scaled [A] or !! unscaled [a] units of var, depending on which optional arguments are provided @@ -271,7 +300,9 @@ function global_volume_mean(var, h, G, GV, scale, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = temp_scale ; if (present(scale)) scalefac = temp_scale * scale + scalefac = temp_scale + if (present(unscale)) then ; scalefac = temp_scale * unscale + elseif (present(scale)) then ; scalefac = temp_scale * scale ; endif tmpForSumming(:,:) = 0. ; sum_weight(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie @@ -286,7 +317,7 @@ end function global_volume_mean !> Find the global mass-weighted integral of a variable. This uses reproducing sums. -function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale) +function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale, unscale) 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)), & @@ -301,6 +332,11 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the !! variable that is reversed in the return value [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. real :: global_mass_integral !< The mass-weighted integral of var (or 1) in !! kg times the arbitrary units of var [kg a] or [kg A ~> kg a] @@ -315,7 +351,9 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale + scalefac = G%US%L_to_m**2*temp_scale + if (present(unscale)) then ; scalefac = scalefac * unscale + elseif (present(scale)) then ; scalefac = scalefac * scale ; endif tmpForSumming(:,:) = 0.0 if (present(var)) then @@ -346,7 +384,7 @@ end function global_mass_integral !> Find the global mass-weighted order invariant integral of a variable in mks units, !! returning the value as an EFP_type. This uses reproducing sums. -function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale) +function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale, unscale) 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)), & @@ -359,6 +397,11 @@ function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale) real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] !! that converts it back to unscaled (e.g., mks) !! units to enable the use of the reproducing sums + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. type(EFP_type) :: global_mass_int_EFP !< The mass-weighted integral of var (or 1) in !! kg times the arbitrary units of var [kg a] @@ -373,7 +416,8 @@ function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale) isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) scalefac = GV%H_to_kg_m2 * G%US%L_to_m**2 - if (present(scale)) scalefac = scale * scalefac + if (present(unscale)) then ; scalefac = unscale * scalefac + elseif (present(scale)) then ; scalefac = scale * scalefac ; endif tmpForSum(:,:) = 0.0 if (present(var)) then @@ -395,7 +439,7 @@ end function global_mass_int_EFP !> Determine the global mean of a field along rows of constant i, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) +subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale, unscale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged in !! arbitrary, possibly rescaled units [A ~> a] @@ -407,14 +451,19 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal !! calculations that is removed from the output [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums type(EFP_type), allocatable, dimension(:) :: asum ! The masked sum of the variable in each row [a] type(EFP_type), allocatable, dimension(:) :: mask_sum ! The sum of the mask values in each row [nondim] - real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] - real :: unscale ! A factor for undoing any internal rescaling before output [A a-1 ~> 1] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: rescale ! A factor for redoing any internal rescaling before output [A a-1 ~> 1] real :: mask_sum_r ! The sum of the mask values in a row [nondim] integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j @@ -422,10 +471,13 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idg_off = G%idg_offset ; jdg_off = G%jdg_offset - scalefac = 1.0 ; if (present(scale)) scalefac = scale - unscale = 1.0 + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(scale)) then ; scalefac = scale ; endif + + rescale = 1.0 if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then - scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + scalefac = scalefac * tmp_scale ; rescale = 1.0 / tmp_scale endif ; endif call reset_EFP_overflow_error() @@ -479,7 +531,7 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) enddo endif - if (unscale /= 1.0) then ; do j=js,je ; i_mean(j) = unscale*i_mean(j) ; enddo ; endif + if (rescale /= 1.0) then ; do j=js,je ; i_mean(j) = rescale*i_mean(j) ; enddo ; endif deallocate(asum) @@ -487,7 +539,7 @@ end subroutine global_i_mean !> Determine the global mean of a field along rows of constant j, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) +subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale, unscale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged in !! arbitrary, possibly rescaled units [A ~> a] @@ -499,6 +551,11 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal !! calculations that is removed from the output [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the @@ -506,18 +563,21 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) type(EFP_type), allocatable, dimension(:) :: asum ! The masked sum of the variable in each row [a] type(EFP_type), allocatable, dimension(:) :: mask_sum ! The sum of the mask values in each row [nondim] real :: mask_sum_r ! The sum of the mask values in a row [nondim] - real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] - real :: unscale ! A factor for undoing any internal rescaling before output [A a-1 ~> 1] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: rescale ! A factor for redoing any internal rescaling before output [A a-1 ~> 1] integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idg_off = G%idg_offset ; jdg_off = G%jdg_offset - scalefac = 1.0 ; if (present(scale)) scalefac = scale - unscale = 1.0 + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(scale)) then ; scalefac = scale ; endif + + rescale = 1.0 if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then - scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + scalefac = scalefac * tmp_scale ; rescale = 1.0 / tmp_scale endif ; endif call reset_EFP_overflow_error() @@ -571,14 +631,14 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) enddo endif - if (unscale /= 1.0) then ; do i=is,ie ; j_mean(i) = unscale*j_mean(i) ; enddo ; endif + if (rescale /= 1.0) then ; do i=is,ie ; j_mean(i) = rescale*j_mean(i) ; enddo ; endif deallocate(asum) end subroutine global_j_mean !> Adjust 2d array such that area mean is zero without moving the zero contour -subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) +subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale, unscale) type(ocean_grid_type), intent(in) :: G !< Grid structure real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: array !< 2D array to be adjusted in !! arbitrary, possibly rescaled units [A ~> a] @@ -586,6 +646,11 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) real, optional, intent(in) :: unit_scale !< A rescaling factor for the variable [a A-1 ~> 1] !! that converts it back to unscaled (e.g., mks) !! units to enable the use of the reproducing sums + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here unit_scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums @@ -598,7 +663,10 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) real :: posScale, negScale ! The scaling factor to apply to positive or negative values [nondim] integer :: i,j - scalefac = 1.0 ; if (present(unit_scale)) scalefac = unit_scale + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(unit_scale)) then ; scalefac = unit_scale ; endif + I_scalefac = 0.0 ; if (scalefac /= 0.0) I_scalefac = 1.0 / scalefac ! areaXposVals(:,:) = 0. ! This zeros out halo points. @@ -636,4 +704,192 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) end subroutine adjust_area_mean_to_zero + +!> Find the global maximum and minimum of a tracer array and return the locations of the extrema. +!! When there multiple cells with the same extreme values, the reported locations are from the +!! uppermost layer where they occur, and then from the logically northernmost and then eastermost +!! such location on the unrotated version of the grid within that layer. Only ocean points (as +!! indicated by a positive value of G%mask2dT) are evaluated, and if there are no ocean points +!! anywhere in the domain, the reported extrema and their locations are all returned as 0. +subroutine array_global_min_max(tr_array, G, nk, g_min, g_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax, unscale) + integer, intent(in) :: nk !< The number of vertical levels + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),nk), intent(in) :: tr_array !< The tracer array to search for + !! extrema in arbitrary concentration units [CU ~> conc] + real, intent(out) :: g_min !< The global minimum of tr_array, either in + !! the same units as tr_array [CU ~> conc] or in + !! unscaled units if unscale is present [conc] + real, intent(out) :: g_max !< The global maximum of tr_array, either in + !! the same units as tr_array [CU ~> conc] or in + !! unscaled units if unscale is present [conc] + real, optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] + real, optional, intent(in) :: unscale !< A factor to use to undo any scaling of + !! the input tracer array [conc CU-1 ~> 1] + + ! Local variables + real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array [CU ~> conc] + integer :: ijk_min_max(2) ! Integers encoding the global grid positions of the global minimum and maximum values + real :: xyz_min_max(6) ! A single array with the x-, y- and z-positions of the minimum and + ! maximum values in units that vary between the array elements [various] + logical :: valid_PE ! True if there are any valid points on the local PE. + logical :: find_location ! If true, report the locations of the extrema + integer :: ijk_loc_max ! An integer encoding the global grid position of the maximum tracer value on this PE + integer :: ijk_loc_min ! An integer encoding the global grid position of the minimum tracer value on this PE + integer :: ijk_loc_here ! An integer encoding the global grid position of the current grid point + integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin + integer :: i, j, k, isc, iec, jsc, jec + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + find_location = (present(xgmin) .or. present(ygmin) .or. present(zgmin) .or. & + present(xgmax) .or. present(ygmax) .or. present(zgmax)) + + ! The initial values set here are never used if there are any valid points. + tmax = -huge(tmax) ; tmin = huge(tmin) + + if (find_location) then + ! Find the maximum and minimum tracer values on this PE and their locations. + valid_PE = .false. + itmax = 0 ; jtmax = 0 ; ktmax = 0 ; ijk_loc_max = 0 + itmin = 0 ; jtmin = 0 ; ktmin = 0 ; ijk_loc_min = 0 + do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then + valid_PE = .true. + if (tr_array(i,j,k) > tmax) then + tmax = tr_array(i,j,k) + itmax = i ; jtmax = j ; ktmax = k + ijk_loc_max = ijk_loc(i, j, k, nk, G%HI) + elseif ((tr_array(i,j,k) == tmax) .and. (k <= ktmax)) then + ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) + if (ijk_loc_here > ijk_loc_max) then + itmax = i ; jtmax = j ; ktmax = k + ijk_loc_max = ijk_loc_here + endif + endif + if (tr_array(i,j,k) < tmin) then + tmin = tr_array(i,j,k) + itmin = i ; jtmin = j ; ktmin = k + ijk_loc_min = ijk_loc(i, j, k, nk, G%HI) + elseif ((tr_array(i,j,k) == tmin) .and. (k <= ktmin)) then + ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) + if (ijk_loc_here > ijk_loc_min) then + itmin = i ; jtmin = j ; ktmin = k + ijk_loc_min = ijk_loc_here + endif + endif + endif ; enddo ; enddo ; enddo + else + ! Only the maximum and minimum values are needed, and not their positions. + do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then + if (tr_array(i,j,k) > tmax) tmax = tr_array(i,j,k) + if (tr_array(i,j,k) < tmin) tmin = tr_array(i,j,k) + endif ; enddo ; enddo ; enddo + endif + + ! Find the global maximum and minimum tracer values. + g_max = tmax ; g_min = tmin + call max_across_PEs(g_max) + call min_across_PEs(g_min) + + if (find_location) then + if (g_max < g_min) then + ! This only occurs if there are no unmasked points anywhere in the domain. + xyz_min_max(:) = 0.0 + else + ! Find the global indices of the maximum and minimum locations. This can + ! occur on multiple PEs. + ijk_min_max(1:2) = 0 + if (valid_PE) then + if (g_min == tmin) ijk_min_max(1) = ijk_loc_min + if (g_max == tmax) ijk_min_max(2) = ijk_loc_max + endif + ! If MOM6 supported taking maxima on arrays of integers, these could be combined as: + ! call max_across_PEs(ijk_min_max, 2) + call max_across_PEs(ijk_min_max(1)) + call max_across_PEs(ijk_min_max(2)) + + ! Set the positions of the extrema if they occur on this PE. This will only + ! occur on a single PE. + xyz_min_max(1:6) = -huge(xyz_min_max) ! These huge negative values are never selected by max_across_PEs. + if (valid_PE) then + if (ijk_min_max(1) == ijk_loc_min) then + xyz_min_max(1) = G%geoLonT(itmin,jtmin) + xyz_min_max(2) = G%geoLatT(itmin,jtmin) + xyz_min_max(3) = real(ktmin) + endif + if (ijk_min_max(2) == ijk_loc_max) then + xyz_min_max(4) = G%geoLonT(itmax,jtmax) + xyz_min_max(5) = G%geoLatT(itmax,jtmax) + xyz_min_max(6) = real(ktmax) + endif + endif + + call max_across_PEs(xyz_min_max, 6) + endif + + if (present(xgmin)) xgmin = xyz_min_max(1) + if (present(ygmin)) ygmin = xyz_min_max(2) + if (present(zgmin)) zgmin = xyz_min_max(3) + if (present(xgmax)) xgmax = xyz_min_max(4) + if (present(ygmax)) ygmax = xyz_min_max(5) + if (present(zgmax)) zgmax = xyz_min_max(6) + endif + + if (g_max < g_min) then + ! There are no unmasked points anywhere in the domain. + g_max = 0.0 ; g_min = 0.0 + endif + + if (present(unscale)) then + ! Rescale g_min and g_max, perhaps changing their units from [CU ~> conc] to [conc] + g_max = unscale * g_max + g_min = unscale * g_min + endif + +end subroutine array_global_min_max + +! Return a positive integer encoding the rotationally invariant global position of a tracer cell +function ijk_loc(i, j, k, nk, HI) + integer, intent(in) :: i !< Local i-index + integer, intent(in) :: j !< Local j-index + integer, intent(in) :: k !< Local k-index + integer, intent(in) :: nk !< Range of k-index, used to pick out a low-k position. + type(hor_index_type), intent(in) :: HI !< Horizontal index ranges + integer :: ijk_loc ! An integer encoding the cell position in the global grid. + + ! Local variables + integer :: ig, jg ! Global index values with a global computational domain start value of 1. + integer :: ij_loc ! The encoding of the horizontal position + integer :: qturns ! The number of counter-clockwise quarter turns of the grid that have to be undone + + ! These global i-grid positions run from 1 to HI%niglobal, and analogously for jg. + ig = i + HI%idg_offset + (1 - HI%isg) + jg = j + HI%jdg_offset + (1 - HI%jsg) + + ! Compensate for the rotation of the model grid to give a rotationally invariant encoding. + qturns = modulo(HI%turns, 4) + if (qturns == 0) then + ij_loc = ig + HI%niglobal * jg + elseif (qturns == 1) then + ij_loc = jg + HI%njglobal * ((HI%niglobal+1)-ig) + elseif (qturns == 2) then + ij_loc = ((HI%niglobal+1)-ig) + HI%niglobal * ((HI%njglobal+1)-jg) + elseif (qturns == 3) then + ij_loc = ((HI%njglobal+1)-jg) + HI%njglobal * ig + endif + + ijk_loc = ij_loc + (HI%niglobal*HI%njglobal) * (nk-k) + +end function ijk_loc + + end module MOM_spatial_means diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 736856d75f..398241b98c 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -20,6 +20,7 @@ module MOM_sum_output use MOM_io, only : axis_info, set_axis_info, delete_axis_info, get_filename_appendix use MOM_io, only : attribute_info, set_attribute_info, delete_attribute_info use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE +use MOM_spatial_means, only : array_global_min_max use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) @@ -124,6 +125,12 @@ module MOM_sum_output !! interval at which the run is stopped. logical :: write_stocks !< If true, write the integrated tracer amounts !! to stdout when the energy files are written. + logical :: write_min_max !< If true, write the maximum and minimum values of temperature, + !! salinity and some tracer concentrations to stdout when the energy + !! files are written. + logical :: write_min_max_loc !< If true, write the locations of the maximum and minimum values + !! of temperature, salinity and some tracer concentrations to stdout + !! when the energy files are written. integer :: previous_calls = 0 !< The number of times write_energy has been called. integer :: prev_n = 0 !< The value of n from the last call. type(MOM_netcdf_file) :: fileenergy_nc !< The file handle for the netCDF version of the energy file. @@ -179,6 +186,15 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, mdl, "WRITE_TRACER_MIN_MAX", CS%write_min_max, & + "If true, write the maximum and minimum values of temperature, salinity and "//& + "some tracer concentrations to stdout when the energy files are written.", & + default=.false., do_not_log=.not.CS%write_stocks, debuggingParam=.true.) + call get_param(param_file, mdl, "WRITE_TRACER_MIN_MAX_LOC", CS%write_min_max_loc, & + "If true, write the locations of the maximum and minimum values of "//& + "temperature, salinity and some tracer concentrations to stdout when the "//& + "energy files are written.", & + default=.false., do_not_log=.not.CS%write_min_max, debuggingParam=.true.) call get_param(param_file, mdl, "DT", CS%dt_in_T, & "The (baroclinic) dynamics time step.", & units="s", scale=US%s_to_T, fail_if_missing=.true.) @@ -404,6 +420,34 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str logical :: date_stamped type(time_type) :: dt_force ! A time_type version of the forcing timestep. + + real :: S_min ! The global minimum unmasked value of the salinity [ppt] + real :: S_max ! The global maximum unmasked value of the salinity [ppt] + real :: S_min_x ! The x-positions of the global salinity minima + ! in the units of G%geoLonT, often [degrees_E] or [km] + real :: S_min_y ! The y-positions of the global salinity minima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: S_min_z ! The z-positions of the global salinity minima [layer] + real :: S_max_x ! The x-positions of the global salinity maxima + ! in the units of G%geoLonT, often [degrees_E] or [km] + real :: S_max_y ! The y-positions of the global salinity maxima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: S_max_z ! The z-positions of the global salinity maxima [layer] + + real :: T_min ! The global minimum unmasked value of the temperature [degC] + real :: T_max ! The global maximum unmasked value of the temperature [degC] + real :: T_min_x ! The x-positions of the global temperature minima + ! in the units of G%geoLonT, often [degreeT_E] or [km] + real :: T_min_y ! The y-positions of the global temperature minima + ! in the units of G%geoLatT, often [degreeT_N] or [km] + real :: T_min_z ! The z-positions of the global temperature minima [layer] + real :: T_max_x ! The x-positions of the global temperature maxima + ! in the units of G%geoLonT, often [degreeT_E] or [km] + real :: T_max_y ! The y-positions of the global temperature maxima + ! in the units of G%geoLatT, often [degreeT_N] or [km] + real :: T_max_z ! The z-positions of the global temperature maxima [layer] + + ! The units of the tracer stock vary between tracers, with [conc] given explicitly by Tr_units. real :: Tr_stocks(MAX_FIELDS_) ! The total amounts of each of the registered tracers [kg conc] real :: Tr_min(MAX_FIELDS_) ! The global minimum unmasked value of the tracers [conc] @@ -527,11 +571,20 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci nTr_stocks = 0 Tr_minmax_avail(:) = .false. - call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & - stock_units=Tr_units, num_stocks=nTr_stocks,& - got_min_max=Tr_minmax_avail, global_min=Tr_min, global_max=Tr_max, & - xgmin=Tr_min_x, ygmin=Tr_min_y, zgmin=Tr_min_z,& - xgmax=Tr_max_x, ygmax=Tr_max_y, zgmax=Tr_max_z) + if (CS%write_min_max .and. CS%write_min_max_loc) then + call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & + stock_units=Tr_units, num_stocks=nTr_stocks,& + got_min_max=Tr_minmax_avail, global_min=Tr_min, global_max=Tr_max, & + xgmin=Tr_min_x, ygmin=Tr_min_y, zgmin=Tr_min_z,& + xgmax=Tr_max_x, ygmax=Tr_max_y, zgmax=Tr_max_z) + elseif (CS%write_min_max) then + call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & + stock_units=Tr_units, num_stocks=nTr_stocks,& + got_min_max=Tr_minmax_avail, global_min=Tr_min, global_max=Tr_max) + else + call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & + stock_units=Tr_units, num_stocks=nTr_stocks) + endif if (nTr_stocks > 0) then do m=1,nTr_stocks vars(num_nc_fields+m) = var_desc(Tr_names(m), units=Tr_units(m), & @@ -540,6 +593,13 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci num_nc_fields = num_nc_fields + nTr_stocks endif + if (CS%use_temperature .and. CS%write_stocks) then + call array_global_min_max(tv%T, G, nz, T_min, T_max, & + T_min_x, T_min_y, T_min_z, T_max_x, T_max_y, T_max_z, unscale=US%C_to_degC) + call array_global_min_max(tv%S, G, nz, S_min, S_max, & + S_min_x, S_min_y, S_min_z, S_max_x, S_max_y, S_max_z, unscale=US%S_to_ppt) + endif + if (CS%previous_calls == 0) then CS%mass_prev_EFP = mass_EFP @@ -847,6 +907,15 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci write(stdout,'(" Total Salt: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & Salt*0.001, Salt_chg*0.001, Salt_anom*0.001, Salt_anom/Salt endif + if (CS%write_min_max .and. CS%write_min_max_loc) then + write(stdout,'(16X,"Salinity Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + S_min, S_min_x, S_min_y, S_min_z + write(stdout,'(16X,"Salinity Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + S_max, S_max_x, S_max_y, S_max_z + elseif (CS%write_min_max) then + write(stdout,'(16X,"Salinity Global Min & Max:",ES24.16,1X,ES24.16)') S_min, S_max + endif + if (Heat == 0.) then write(stdout,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5)') & Heat, Heat_chg, Heat_anom @@ -854,17 +923,28 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci write(stdout,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & Heat, Heat_chg, Heat_anom, Heat_anom/Heat endif + if (CS%write_min_max .and. CS%write_min_max_loc) then + write(stdout,'(16X,"Temperature Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + T_min, T_min_x, T_min_y, T_min_z + write(stdout,'(16X,"Temperature Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + T_max, T_max_x, T_max_y, T_max_z + elseif (CS%write_min_max) then + write(stdout,'(16X,"Temperature Global Min & Max:",ES24.16,1X,ES24.16)') T_min, T_max + endif endif do m=1,nTr_stocks - write(stdout,'(" Total ",a,": ",ES24.16,1X,a)') & + write(stdout,'(" Total ",a,": ",ES24.16,1X,a)') & trim(Tr_names(m)), Tr_stocks(m), trim(Tr_units(m)) - if (Tr_minmax_avail(m)) then - write(stdout,'(64X,"Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & - Tr_min(m),Tr_min_x(m),Tr_min_y(m),Tr_min_z(m) - write(stdout,'(64X,"Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & - Tr_max(m),Tr_max_x(m),Tr_max_y(m),Tr_max_z(m) + if (CS%write_min_max .and. CS%write_min_max_loc .and. Tr_minmax_avail(m)) then + write(stdout,'(18X,a," Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + trim(Tr_names(m)), Tr_min(m), Tr_min_x(m), Tr_min_y(m), Tr_min_z(m) + write(stdout,'(18X,a," Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + trim(Tr_names(m)), Tr_max(m), Tr_max_x(m), Tr_max_y(m), Tr_max_z(m) + elseif (CS%write_min_max .and. Tr_minmax_avail(m)) then + write(stdout,'(18X,a," Global Min & Max:",ES24.16,1X,ES24.16)') & + trim(Tr_names(m)), Tr_min(m), Tr_max(m) endif enddo diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 5caf47a51c..1c508ec490 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -51,7 +51,9 @@ module MOM_wave_speed !! are simply reported as 0 [L T-1 ~> m s-1]. A non-negative !! value must be specified via a call to wave_speed_init for !! the subroutine wave_speeds to be used (but not wave_speed). - type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic + type(remapping_CS) :: remap_2018_CS !< Used for vertical remapping when calculating equivalent barotropic + !! mode structure for answer dates below 20190101. + type(remapping_CS) :: remap_CS !< Used for vertical remapping when calculating equivalent barotropic !! mode structure. integer :: remap_answer_date = 99991231 !< The vintage of the order of arithmetic and expressions to use !! for remapping. Values below 20190101 recover the remapping @@ -674,13 +676,11 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N endif if (CS%remap_answer_date < 20190101) then - call remapping_core_h(CS%remapping_CS, kc, Hc(:), mode_struct, & - nz, h(i,j,:), modal_structure(i,j,:), & - 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + call remapping_core_h(CS%remap_2018_CS, kc, Hc(:), mode_struct, & + nz, h(i,j,:), modal_structure(i,j,:)) else - call remapping_core_h(CS%remapping_CS, kc, Hc(:), mode_struct, & - nz, h(i,j,:), modal_structure(i,j,:), & - GV%H_subroundoff, GV%H_subroundoff) + call remapping_core_h(CS%remap_CS, kc, Hc(:), mode_struct, & + nz, h(i,j,:), modal_structure(i,j,:)) endif endif else @@ -1357,9 +1357,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s nz, h(i,j,:), modal_structure(:), .false.) ! for u (remap) onto all layers - call remapping_core_h(CS%remapping_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & - nz, h(i,j,:), modal_structure_fder(:), & - GV%H_subroundoff, GV%H_subroundoff) + call remapping_core_h(CS%remap_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & + nz, h(i,j,:), modal_structure_fder(:)) ! write the wave structure do k=1,nz+1 @@ -1533,9 +1532,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s nz, h(i,j,:), modal_structure(:), .false.) ! for u (remap) onto all layers - call remapping_core_h(CS%remapping_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & - nz, h(i,j,:), modal_structure_fder(:), & - GV%H_subroundoff, GV%H_subroundoff) + call remapping_core_h(CS%remap_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & + nz, h(i,j,:), modal_structure_fder(:)) ! write the wave structure ! note that m=1 solves for 2nd mode,... @@ -1610,9 +1608,11 @@ subroutine tridiag_det(a, c, ks, ke, lam, det, ddet, row_scale) end subroutine tridiag_det !> Initialize control structure for MOM_wave_speed -subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & - remap_answer_date, better_speed_est, min_speed, wave_speed_tol, c1_thresh) +subroutine wave_speed_init(CS, GV, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & + remap_answer_date, better_speed_est, om4_remap_via_sub_cells, & + min_speed, wave_speed_tol, c1_thresh) type(wave_speed_CS), intent(inout) :: CS !< Wave speed control struct + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over @@ -1630,6 +1630,8 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! forms of the same remapping expressions. logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first !! mode speed as the starting point for iterations. + logical, optional, intent(in) :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells + !! for calculating the EBT structure real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed !! below which 0 is returned [L T-1 ~> m s-1]. real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the @@ -1654,9 +1656,18 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de remap_answers_2018=remap_answers_2018, remap_answer_date=remap_answer_date, & c1_thresh=c1_thresh) - ! The remap_answers_2018 argument here is irrelevant, because remapping is hard-coded to use PLM. - call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & - answer_date=CS%remap_answer_date) + ! The following remapping is only used for wave_speed with pre-2019 answers. + if (CS%remap_answer_date < 20190101) & + call initialize_remapping(CS%remap_2018_CS, 'PLM', boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%remap_answer_date, & + h_neglect=1.0e-30*GV%m_to_H, h_neglect_edge=1.0e-10*GV%m_to_H) + + ! This is used in wave_speeds in all cases, and in wave_speed with newer answers. + call initialize_remapping(CS%remap_CS, 'PLM', boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%remap_answer_date, & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) end subroutine wave_speed_init diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 1567d20692..938634c1ea 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1226,7 +1226,7 @@ end function EOS_domain !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -1259,10 +1259,12 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_tiny !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! Local variables real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] @@ -1280,20 +1282,20 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, dza, & intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) case (EOS_WRIGHT) call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + inty_dza, halo_size, bathyP, P_surf, dP_tiny, MassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case (EOS_WRIGHT_FULL) call int_spec_vol_dp_wright_full(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + inty_dza, halo_size, bathyP, P_surf, dP_tiny, MassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case (EOS_WRIGHT_REDUCED) call int_spec_vol_dp_wright_red(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + inty_dza, halo_size, bathyP, P_surf, dP_tiny, MassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case default @@ -1306,7 +1308,7 @@ end subroutine analytic_int_specific_vol_dp !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -1342,10 +1344,13 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real :: rho_scale ! A multiplicative factor by which to scale density from kg m-3 to the @@ -1366,50 +1371,50 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, if ((rho_scale /= 1.0) .or. (dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0)) then call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & rho_scale*EOS%Rho_T0_S0, dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp) else call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp) endif case (EOS_WRIGHT) rho_scale = EOS%kg_m3_to_R pres_scale = EOS%RL2_T2_to_Pa if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, rho_scale, pres_scale, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) else call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case (EOS_WRIGHT_FULL) rho_scale = EOS%kg_m3_to_R pres_scale = EOS%RL2_T2_to_Pa if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, rho_scale, pres_scale, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) else call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case (EOS_WRIGHT_REDUCED) rho_scale = EOS%kg_m3_to_R pres_scale = EOS%RL2_T2_to_Pa if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, rho_scale, pres_scale, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) else call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case default call MOM_error(FATAL, "No analytic integration option is available with this EOS!") @@ -2423,7 +2428,7 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & tol_here = 0.5*tol*(abs(SpV_avg_a(1)) + abs(SpV_avg_q(1))) test_OK = (abs(SpV_avg_a(1) - SpV_avg_q(1)) < tol_here) if (verbose) then - write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2,"), tol=",ES16.8)') & SpV_avg_a(1), SpV_avg_q(1), SpV_avg_a(1) - SpV_avg_q(1), & 2.0*(SpV_avg_a(1) - SpV_avg_q(1)) / (abs(SpV_avg_a(1)) + abs(SpV_avg_q(1)) + tiny(SpV_avg_a(1))), & tol_here @@ -2503,8 +2508,7 @@ logical function check_FD(val, val_fd, tol, verbose, field_name, order) check_FD = ( abs(val_fd(1) - val) < (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) ) - ! write(mesg, '(ES16.8," and ",ES16.8," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & - write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2,"), tol=",ES16.8)') & val, val_fd(1), val - val_fd(1), & 2.0*(val - val_fd(1)) / (abs(val) + abs(val_fd(1)) + tiny(val)), & (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 38eeab7c81..874d3e784e 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -387,8 +387,8 @@ end subroutine EoS_fit_range_buggy_Wright !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & - useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, & + MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -424,9 +424,11 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -435,12 +437,14 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! temperature into degC [degC C-1 ~> 1] real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure !! into PSU [PSU S-1 ~> 1]. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: al0 ! A term in the Wright EOS [m3 kg-1] real :: p0 ! A term in the Wright EOS [Pa] real :: lambda ! A term in the Wright EOS [m2 s-2] @@ -466,7 +470,6 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by ! pres_scale [R L2 T-2 Pa-1 ~> 1]. - real :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] @@ -480,6 +483,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m @@ -504,7 +508,13 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & else rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 endif - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif a1s = a1 ; a2s = a2 b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 @@ -524,14 +534,11 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if useMassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 al0_2d(i,j) = (a0 + a1s*T(i,j)) + a2s*S(i,j) @@ -541,7 +548,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dz = z_t(i,j) - z_b(i,j) - p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -564,6 +571,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect @@ -585,7 +594,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -605,6 +615,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect @@ -626,7 +638,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres) + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -647,8 +660,8 @@ end subroutine int_density_dz_wright !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & - intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & - useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + intp_dza, intx_dza, inty_dza, halo_size, bathyP, P_surf, dP_neglect, & + MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -684,10 +697,12 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & !! dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -734,6 +749,8 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -770,14 +787,12 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. -! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if useMassWghtInterp is present and true.") -! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) do j=jsh,jeh ; do i=ish,ieh @@ -802,8 +817,13 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -843,8 +863,13 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 41d3608db7..4be5f2940e 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -393,8 +393,8 @@ end subroutine EoS_fit_range_Wright_full !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & - useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, & + MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -430,9 +430,11 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -441,12 +443,14 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! temperature into degC [degC C-1 ~> 1] real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure !! into PSU [PSU S-1 ~> 1]. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: al0 ! A term in the Wright EOS [m3 kg-1] real :: p0 ! A term in the Wright EOS [Pa] real :: lambda ! A term in the Wright EOS [m2 s-2] @@ -472,7 +476,6 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by ! pres_scale [R L2 T-2 Pa-1 ~> 1]. - real :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] @@ -486,6 +489,7 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m @@ -510,7 +514,13 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & else rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 endif - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif a1s = a1 ; a2s = a2 b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 @@ -530,14 +540,11 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if useMassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) @@ -547,7 +554,7 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dz = z_t(i,j) - z_b(i,j) - p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -569,6 +576,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect @@ -590,7 +599,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -610,6 +620,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect @@ -631,7 +643,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres) + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -652,8 +665,8 @@ end subroutine int_density_dz_wright_full !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & - intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & - useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + intp_dza, intx_dza, inty_dza, halo_size, bathyP, P_surf, dP_neglect, & + MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -689,10 +702,12 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & !! dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -740,6 +755,8 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -776,14 +793,12 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. -! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if useMassWghtInterp is present and true.") -! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif ! alpha = (lambda + al0*(pressure + p0)) / (pressure + p0) do j=jsh,jeh ; do i=ish,ieh @@ -809,8 +824,13 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -851,8 +871,13 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index dc637e6700..1635f9e809 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -395,8 +395,8 @@ end subroutine EoS_fit_range_Wright_red !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & - useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, & + MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -432,9 +432,11 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -443,12 +445,14 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! temperature into degC [degC C-1 ~> 1] real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure !! into PSU [PSU S-1 ~> 1]. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: al0 ! A term in the Wright EOS [m3 kg-1] real :: p0 ! A term in the Wright EOS [Pa] real :: lambda ! A term in the Wright EOS [m2 s-2] @@ -474,7 +478,6 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by ! pres_scale [R L2 T-2 Pa-1 ~> 1]. - real :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] @@ -488,6 +491,7 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m @@ -512,7 +516,13 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & else rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 endif - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif a1s = a1 ; a2s = a2 b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 @@ -532,14 +542,11 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if useMassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) @@ -549,7 +556,7 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dz = z_t(i,j) - z_b(i,j) - p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -571,6 +578,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect @@ -592,7 +601,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -612,6 +622,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect @@ -633,7 +645,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres) + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -654,8 +667,8 @@ end subroutine int_density_dz_wright_red !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & - intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & - useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + intp_dza, intx_dza, inty_dza, halo_size, bathyP, P_surf, dP_neglect, & + MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -691,10 +704,12 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & !! dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -742,6 +757,8 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -778,14 +795,12 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. -! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if useMassWghtInterp is present and true.") -! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) do j=jsh,jeh ; do i=ish,ieh @@ -811,8 +826,13 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -853,8 +873,13 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 490885aacc..e443970535 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -258,7 +258,7 @@ end subroutine set_params_linear !! finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & Rho_T0_S0, dRho_dT, dRho_dS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) + bathyT, SSH, dz_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -299,9 +299,11 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! Local variables real :: rho_anom ! The density anomaly from rho_ref [R ~> kg m-3]. @@ -317,6 +319,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & real :: intz(5) ! The integrals of density with height at the ! 5 sub-column locations [R L2 T-2 ~> Pa] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants [nondim]. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m @@ -327,14 +330,11 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & is = HI%isc ; ie = HI%iec js = HI%jsc ; je = HI%jec - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if useMassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz = z_t(i,j) - z_b(i,j) @@ -350,6 +350,8 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght <= 0.0) then dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i+1,j) - z_b(i+1,j) @@ -389,6 +391,8 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght <= 0.0) then dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i,j+1) - z_b(i,j+1) @@ -429,7 +433,7 @@ end subroutine int_density_dz_linear !! model. Specific volume is assumed to vary linearly between adjacent points. subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & dRho_dT, dRho_dS, dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, useMassWghtInterp) + bathyP, P_surf, dP_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -469,10 +473,12 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! Local variables real :: dRho_TS ! The density anomaly due to T and S [R ~> kg m-3] real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [R-1 ~> m3 kg-1] @@ -488,6 +494,8 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants [nondim]. integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -497,14 +505,12 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. -! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if useMassWghtInterp is present and true.") -! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif do j=jsh,jeh ; do i=ish,ieh dp = p_b(i,j) - p_t(i,j) @@ -520,8 +526,13 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght <= 0.0) then dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i+1,j) - p_t(i+1,j) @@ -565,8 +576,13 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght <= 0.0) then dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i,j+1) - p_t(i,j+1) diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 00e4ba4918..4e349e0fb7 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -102,13 +102,17 @@ module MOM_checksums contains !> Checksum a scalar field (consistent with array checksums) -subroutine chksum0(scalar, mesg, scale, logunit) +subroutine chksum0(scalar, mesg, scale, logunit, unscale) real, intent(in) :: scalar !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] character(len=*), intent(in) :: mesg !< An identifying message real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -122,7 +126,10 @@ subroutine chksum0(scalar, mesg, scale, logunit) if (checkForNaNs .and. is_NaN(scalar)) & call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then @@ -141,13 +148,17 @@ end subroutine chksum0 !> Checksum a 1d array (typically a column). -subroutine zchksum(array, mesg, scale, logunit) +subroutine zchksum(array, mesg, scale, logunit, unscale) real, dimension(:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] character(len=*), intent(in) :: mesg !< An identifying message real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -165,14 +176,17 @@ subroutine zchksum(array, mesg, scale, logunit) call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate(rescaled_array(LBOUND(array,1):UBOUND(array,1)), source=0.0) do k=1, size(array, 1) - rescaled_array(k) = scale * array(k) + rescaled_array(k) = scaling * array(k) enddo call subStats(rescaled_array, aMean, aMin, aMax) @@ -192,15 +206,15 @@ subroutine zchksum(array, mesg, scale, logunit) contains - integer function subchk(array, scale) + integer function subchk(array, unscale) real, dimension(:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] - real, intent(in) :: scale !< A factor to convert this array back to unscaled units - !! for checksums and output [a A-1 ~> 1] + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: k, bc subchk = 0 do k=LBOUND(array, 1), UBOUND(array, 1) - bc = bitcount(abs(scale * array(k))) + bc = bitcount(abs(unscale * array(k))) subchk = subchk + bc enddo subchk=mod(subchk, bc_modulus) @@ -228,7 +242,7 @@ end subroutine zchksum !> Checksums on a pair of 2d arrays staggered at tracer points. subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & - scale, logunit, scalar_pair) + scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed in @@ -242,6 +256,10 @@ subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -271,18 +289,18 @@ subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & if (present(haloshift)) then call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) else - call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit) - call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit) + call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) + call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_pair_h_2d !> Checksums on a pair of 3d arrays staggered at tracer points. subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & - scale, logunit, scalar_pair) + scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayA !< The first array to be checksummed in @@ -296,6 +314,11 @@ subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -325,19 +348,19 @@ subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & if (present(haloshift)) then call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) else - call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit) - call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit) + call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) + call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) endif ! NOTE: automatic deallocation of array[AB]_in end subroutine chksum_pair_h_3d !> Checksums a 2d array staggered at tracer points. -subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) +subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< Horizontal index bounds of the model grid real, dimension(HI_m%isd:,HI_m%jsd:), target, intent(in) :: array_m !< Field array on the model grid in !! arbitrary, possibly rescaled units [A ~> a] @@ -347,6 +370,10 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -383,15 +410,18 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - rescaled_array(i,j) = scale*array(i,j) + rescaled_array(i,j) = scaling*array(i,j) enddo ; enddo call subStats(HI, rescaled_array, aMean, aMin, aMax) deallocate(rescaled_array) @@ -445,18 +475,18 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu endif contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,j))) + bc = bitcount(abs(unscale*array(i,j))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -491,7 +521,7 @@ end subroutine chksum_h_2d !> Checksums on a pair of 2d arrays staggered at q-points. subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed in @@ -507,6 +537,10 @@ subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. logical :: sym logical :: vector_pair @@ -540,21 +574,21 @@ subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric=sym, & - omit_corners=omit_corners, scale=scale, logunit=logunit) + omit_corners=omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric=sym, & - omit_corners=omit_corners, scale=scale, logunit=logunit) + omit_corners=omit_corners, scale=scale, logunit=logunit, unscale=unscale) else - call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, symmetric=sym, scale=scale, & - logunit=logunit) - call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, symmetric=sym, scale=scale, & - logunit=logunit) + call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, symmetric=sym, & + scale=scale, logunit=logunit, unscale=unscale) + call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, symmetric=sym, & + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_pair_B_2d !> Checksums on a pair of 3d arrays staggered at q-points. subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayA !< The first array to be checksummed in @@ -570,7 +604,11 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe !! a scalar, rather than vector - + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -600,20 +638,20 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) else - call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, symmetric=symmetric, scale=scale, & - logunit=logunit) - call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, symmetric=symmetric, scale=scale, & - logunit=logunit) + call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit, unscale=unscale) + call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_pair_B_3d !> Checksums a 2d array staggered at corner points. subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%IsdB:,HI_m%JsdB:), & target, intent(in) :: array_m !< The array to be checksummed in @@ -626,6 +664,10 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -662,19 +704,22 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do J=Js,HI%JecB ; do I=Is,HI%IecB - rescaled_array(I,J) = scale*array(I,J) + rescaled_array(I,J) = scaling*array(I,J) enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -736,19 +781,19 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do J=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,J))) + bc = bitcount(abs(unscale*array(I,J))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -787,7 +832,7 @@ end subroutine chksum_B_2d !> Checksums a pair of 2d velocity arrays staggered at C-grid locations subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:), target, intent(in) :: arrayU !< The u-component array to be checksummed in @@ -803,6 +848,11 @@ subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -832,20 +882,20 @@ subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_u_2d(arrayU_in, 'u '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_v_2d(arrayV_in, 'v '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) else call chksum_u_2d(arrayU_in, 'u '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_v_2d(arrayV_in, 'v '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_uv_2d !> Checksums a pair of 3d velocity arrays staggered at C-grid locations subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:,:), target, intent(in) :: arrayU !< The u-component array to be checksummed in @@ -861,6 +911,11 @@ subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -890,20 +945,20 @@ subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_u_3d(arrayU_in, 'u '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_v_3d(arrayV_in, 'v '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) else call chksum_u_3d(arrayU_in, 'u '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_v_3d(arrayV_in, 'v '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_uv_3d !> Checksums a 2d array staggered at C-grid u points. subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%IsdB:,HI_m%jsd:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -915,6 +970,10 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -941,7 +1000,8 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from v-points must be handled by vchksum allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB)) call rotate_array(array_m, -turns, array) - call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed)) @@ -959,18 +1019,21 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 do j=HI%jsc,HI%jec ; do I=Is,HI%IecB - rescaled_array(I,j) = scale*array(I,j) + rescaled_array(I,j) = scaling*array(I,j) enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1039,19 +1102,19 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do j=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,j))) + bc = bitcount(abs(unscale*array(I,j))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -1089,7 +1152,7 @@ end subroutine chksum_u_2d !> Checksums a 2d array staggered at C-grid v points. subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%isd:,HI_m%JsdB:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -1101,6 +1164,10 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -1127,7 +1194,8 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from u-points must be handled by uchksum allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed)) call rotate_array(array_m, -turns, array) - call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB)) @@ -1145,18 +1213,21 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do J=Js,HI%JecB ; do i=HI%isc,HI%iec - rescaled_array(i,J) = scale*array(i,J) + rescaled_array(i,J) = scaling*array(i,J) enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1225,19 +1296,19 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do J=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,J))) + bc = bitcount(abs(unscale*array(i,J))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -1274,7 +1345,7 @@ end subroutine subStats end subroutine chksum_v_2d !> Checksums a 3d array staggered at tracer points. -subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) +subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%isd:,HI_m%jsd:,:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -1284,6 +1355,10 @@ subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -1320,16 +1395,19 @@ subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - rescaled_array(i,j,k) = scale*array(i,j,k) + rescaled_array(i,j,k) = scaling*array(i,j,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, aMean, aMin, aMax) @@ -1385,18 +1463,18 @@ subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,j,k))) + bc = bitcount(abs(unscale*array(i,j,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) @@ -1431,7 +1509,7 @@ end subroutine chksum_h_3d !> Checksums a 3d array staggered at corner points. subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%IsdB:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -1443,6 +1521,10 @@ subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -1479,20 +1561,23 @@ subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do k=1,size(array,3) ; do J=Js,HI%JecB ; do I=Is,HI%IecB - rescaled_array(I,J,k) = scale*array(I,J,k) + rescaled_array(I,J,k) = scaling*array(I,J,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1560,19 +1645,19 @@ subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do J=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,J,k))) + bc = bitcount(abs(unscale*array(I,J,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) @@ -1610,7 +1695,7 @@ end subroutine chksum_B_3d !> Checksums a 3d array staggered at C-grid u points. subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%isdB:,HI_m%Jsd:,:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -1622,6 +1707,10 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -1648,7 +1737,8 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from v-points must be handled by vchksum allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB, size(array_m, 3))) call rotate_array(array_m, -turns, array) - call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed, size(array_m, 3))) @@ -1666,19 +1756,22 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do I=Is,HI%IecB - rescaled_array(I,j,k) = scale*array(I,j,k) + rescaled_array(I,j,k) = scaling*array(I,j,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1746,19 +1839,19 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,j,k))) + bc = bitcount(abs(unscale*array(I,j,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) @@ -1796,7 +1889,7 @@ end subroutine chksum_u_3d !> Checksums a 3d array staggered at C-grid v points. subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%isd:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -1808,6 +1901,10 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -1834,7 +1931,8 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from u-points must be handled by uchksum allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed, size(array_m, 3))) call rotate_array(array_m, -turns, array) - call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB, size(array_m, 3))) @@ -1852,19 +1950,22 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do k=1,size(array,3) ; do J=Js,HI%JecB ; do i=HI%isc,HI%iec - rescaled_array(i,J,k) = scale*array(i,J,k) + rescaled_array(i,J,k) = scaling*array(i,J,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1932,19 +2033,19 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do J=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,J,k))) + bc = bitcount(abs(unscale*array(i,J,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index 38ad55fd96..e4f5235da8 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -4,6 +4,7 @@ module MOM_coms ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : int64 use MOM_coms_infra, only : PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist use MOM_coms_infra, only : broadcast, field_chksum, MOM_infra_init, MOM_infra_end use MOM_coms_infra, only : sum_across_PEs, max_across_PEs, min_across_PEs @@ -25,9 +26,9 @@ module MOM_coms ! This module provides interfaces to the non-domain-oriented communication subroutines. -integer(kind=8), parameter :: prec=2_8**46 !< The precision of each integer. -real, parameter :: r_prec=2.0**46 !< A real version of prec. -real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec. +integer(kind=int64), parameter :: prec = (2_int64)**46 !< The precision of each integer. +real, parameter :: r_prec=2.0**46 !< A real version of prec [nondim]. +real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec [nondim]. integer, parameter :: max_count_prec=2**(63-46)-1 !< The number of values that can be added together !! with the current value of prec before there will @@ -37,12 +38,12 @@ module MOM_coms !< a real number. real, parameter, dimension(ni) :: & pr = (/ r_prec**2, r_prec, 1.0, 1.0/r_prec, 1.0/r_prec**2, 1.0/r_prec**3 /) - !< An array of the real precision of each of the integers + !< An array of the real precision of each of the integers in arbitrary units [a] real, parameter, dimension(ni) :: & I_pr = (/ 1.0/r_prec**2, 1.0/r_prec, 1.0, r_prec, r_prec**2, r_prec**3 /) - !< An array of the inverse of the real precision of each of the integers + !< An array of the inverse of the real precision of each of the integers in arbitrary units [a-1] real, parameter :: max_efp_float = pr(1) * (2.**63 - 1.) - !< The largest float with an EFP representation. + !< The largest float with an EFP representation in arbitrary units [a]. !! NOTE: Only the first bin can exceed precision, !! but is bounded by the largest signed integer. @@ -73,7 +74,7 @@ module MOM_coms !! Hallberg, R. & A. Adcroft, 2014: An Order-invariant Real-to-Integer Conversion Sum. !! Parallel Computing, 40(5-6), doi:10.1016/j.parco.2014.04.007. type, public :: EFP_type ; private - integer(kind=8), dimension(ni) :: v !< The value in this type + integer(kind=int64), dimension(ni) :: v !< The value in this type end type EFP_type !> Add two extended-fixed-point numbers @@ -91,7 +92,7 @@ module MOM_coms !! using EFP_to_real. This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, !! doi:10.1016/j.parco.2014.04.007. function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, only_on_PE) result(EFP_sum) - real, dimension(:,:), intent(in) :: array !< The array to be summed + real, dimension(:,:), intent(in) :: array !< The array to be summed in arbitrary units [a] integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting !! that the array indices starts at 1 integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting @@ -115,10 +116,10 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8) :: ival, prec_error - real :: rs - real :: max_mag_term + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64) :: ival, prec_error + real :: rs ! The remaining value to add, in arbitrary units [a] + real :: max_mag_term ! A running maximum magnitude of the values in arbitrary units [a] logical :: over_check, do_sum_across_PEs character(len=256) :: mesg integer :: i, j, n, is, ie, js, je, sgn @@ -127,7 +128,7 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) if (present(isr)) then @@ -176,7 +177,7 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, sgn = 1 ; if (array(i,j)<0.0) sgn = -1 rs = abs(array(i,j)) do n=1,ni - ival = int(rs*I_pr(n), 8) + ival = int(rs*I_pr(n), kind=int64) rs = rs - ival*pr(n) ints_sum(n) = ints_sum(n) + sgn*ival enddo @@ -218,7 +219,7 @@ end function reproducing_EFP_sum_2d !! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & overflow_check, err, only_on_PE) result(sum) - real, dimension(:,:), intent(in) :: array !< The array to be summed + real, dimension(:,:), intent(in) :: array !< The array to be summed in arbitrary units [a] integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting !! that the array indices starts at 1 integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting @@ -239,15 +240,15 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & !! this routine. logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum !! across processors, only reporting the local sum - real :: sum !< Result + real :: sum !< The sum of the values in array in arbitrary units [a] ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8) :: prec_error - real :: rsum(1) + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64) :: prec_error + real :: rsum(1) ! The running sum, in arbitrary units [a] logical :: repro, do_sum_across_PEs character(len=256) :: mesg type(EFP_type) :: EFP_val ! An extended fixed point version of the sum @@ -257,7 +258,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) if (present(isr)) then @@ -323,7 +324,7 @@ end function reproducing_sum_2d !! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_sums, err, only_on_PE) & result(sum) - real, dimension(:,:,:), intent(in) :: array !< The array to be summed + real, dimension(:,:,:), intent(in) :: array !< The array to be summed in arbitrary units [a] integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting !! that the array indices starts at 1 integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting @@ -332,7 +333,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su !! that the array indices starts at 1 integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting !! that the array indices starts at 1 - real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer + real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer in abitrary units [a] type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format type(EFP_type), dimension(:), & optional, intent(out) :: EFP_lay_sums !< The sums by vertical layer in EFP format @@ -341,16 +342,17 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su !! this routine. logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum !! across processors, only reporting the local sum - real :: sum !< Result + real :: sum !< The sum of the values in array in arbitrary units [a] ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - real :: val, max_mag_term - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8), dimension(ni,size(array,3)) :: ints_sums - integer(kind=8) :: prec_error + real :: val ! The real number that is extracted in arbitrary units [a] + real :: max_mag_term ! A running maximum magnitude of the val's in arbitrary units [a] + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64), dimension(ni,size(array,3)) :: ints_sums + integer(kind=int64) :: prec_error character(len=256) :: mesg logical :: do_sum_across_PEs integer :: i, j, k, is, ie, js, je, ke, isz, jsz, n @@ -359,7 +361,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() max_mag_term = 0.0 is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) ; ke = size(array,3) @@ -506,24 +508,24 @@ end function reproducing_sum_3d !> Convert a real number into the array of integers constitute its extended-fixed-point representation function real_to_ints(r, prec_error, overflow) result(ints) - real, intent(in) :: r !< The real number being converted - integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + real, intent(in) :: r !< The real number being converted in arbitrary units [a] + integer(kind=int64), optional, intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being !! done on a value that is too large to be represented - integer(kind=8), dimension(ni) :: ints + integer(kind=int64), dimension(ni) :: ints ! This subroutine converts a real number to an equivalent representation ! using several long integers. - real :: rs + real :: rs ! The remaining value to add, in arbitrary units [a] character(len=80) :: mesg - integer(kind=8) :: ival, prec_err + integer(kind=int64) :: ival, prec_err integer :: sgn, i prec_err = prec ; if (present(prec_error)) prec_err = prec_error - ints(:) = 0_8 + ints(:) = 0 if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif sgn = 1 ; if (r<0.0) sgn = -1 @@ -538,7 +540,7 @@ function real_to_ints(r, prec_error, overflow) result(ints) endif do i=1,ni - ival = int(rs*I_pr(i), 8) + ival = int(rs*I_pr(i), kind=int64) rs = rs - ival*pr(i) ints(i) = sgn*ival enddo @@ -548,8 +550,8 @@ end function real_to_ints !> Convert the array of integers that constitute an extended-fixed-point !! representation into a real number function ints_to_real(ints) result(r) - integer(kind=8), dimension(ni), intent(in) :: ints !< The array of EFP integers - real :: r + integer(kind=int64), dimension(ni), intent(in) :: ints !< The array of EFP integers + real :: r ! The real number that is extracted in arbitrary units [a] ! This subroutine reverses the conversion in real_to_ints. integer :: i @@ -561,9 +563,9 @@ end function ints_to_real !> Increment an array of integers that constitutes an extended-fixed-point !! representation with a another EFP number subroutine increment_ints(int_sum, int2, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented - integer(kind=8), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added - integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=int64), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added + integer(kind=int64), optional, intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. @@ -595,15 +597,16 @@ end subroutine increment_ints !> Increment an EFP number with a real number without doing any carrying of !! of overflows and using only minimal error checking. subroutine increment_ints_faster(int_sum, r, max_mag_term) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented - real, intent(in) :: r !< The real number being added. - real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's. + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + real, intent(in) :: r !< The real number being added in arbitrary units [a] + real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's + !! in arbitrary units [a] ! This subroutine increments a number with another, both using the integer ! representation in real_to_ints, but without doing any carrying of overflow. ! The entire operation is embedded in a single call for greater speed. - real :: rs - integer(kind=8) :: ival + real :: rs ! The remaining value to add, in arbitrary units [a] + integer(kind=int64) :: ival integer :: sgn, i if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif @@ -618,7 +621,7 @@ subroutine increment_ints_faster(int_sum, r, max_mag_term) endif do i=1,ni - ival = int(rs*I_pr(i), 8) + ival = int(rs*I_pr(i), kind=int64) rs = rs - ival*pr(i) int_sum(i) = int_sum(i) + sgn*ival enddo @@ -627,9 +630,9 @@ end subroutine increment_ints_faster !> This subroutine handles carrying of the overflow. subroutine carry_overflow(int_sum, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being !! modified by carries, but without changing value. - integer(kind=8), intent(in) :: prec_error !< The PE-count dependent precision of the + integer(kind=int64), intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. @@ -651,7 +654,7 @@ end subroutine carry_overflow !> This subroutine carries the overflow, and then makes sure that !! all integers are of the same sign as the overall value. subroutine regularize_ints(int_sum) - integer(kind=8), dimension(ni), & + integer(kind=int64), dimension(ni), & intent(inout) :: int_sum !< The array of integers being modified to take a !! regular form with all integers of the same sign, !! but without changing value. @@ -740,7 +743,7 @@ end subroutine EFP_assign !> Return the real number that an extended-fixed-point number corresponds with function EFP_to_real(EFP1) type(EFP_type), intent(inout) :: EFP1 !< The extended fixed point number being converted - real :: EFP_to_real + real :: EFP_to_real !< The real version of the number in abitrary units [a] call regularize_ints(EFP1%v) EFP_to_real = ints_to_real(EFP1%v) @@ -752,7 +755,7 @@ function EFP_real_diff(EFP1, EFP2) type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being !! subtracted from the first extended fixed point number - real :: EFP_real_diff !< The real result + real :: EFP_real_diff !< The real result in arbitrary units [a] type(EFP_type) :: EFP_diff @@ -763,7 +766,7 @@ end function EFP_real_diff !> Return the extended-fixed-point number that a real number corresponds with function real_to_EFP(val, overflow) - real, intent(in) :: val !< The real number being converted + real, intent(in) :: val !< The real number being converted in arbitrary units [a] logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being !! done on a value that is too large to be represented type(EFP_type) :: real_to_EFP @@ -797,8 +800,8 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. - integer(kind=8), dimension(ni,nval) :: ints - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni,nval) :: ints + integer(kind=int64) :: prec_error logical :: error_found character(len=256) :: mesg integer :: i, n @@ -807,7 +810,7 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() ! overflow_error is an overflow error flag for the whole module. overflow_error = .false. ; error_found = .false. @@ -844,8 +847,8 @@ subroutine EFP_val_sum_across_PEs(EFP, error) ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. - integer(kind=8), dimension(ni) :: ints - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni) :: ints + integer(kind=int64) :: prec_error logical :: error_found character(len=256) :: mesg integer :: n @@ -854,7 +857,7 @@ subroutine EFP_val_sum_across_PEs(EFP, error) "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() ! overflow_error is an overflow error flag for the whole module. overflow_error = .false. ; error_found = .false. diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index f87b409694..b931a2ddd2 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -3,6 +3,7 @@ module MOM_coupler_types ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_couplertype_infra, only : CT_spawn, CT_initialized, CT_destructor, atmos_ocn_coupler_flux use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums, CT_data_override use MOM_couplertype_infra, only : CT_copy_data, CT_increment_data, CT_rescale_data @@ -246,11 +247,15 @@ end subroutine CT_copy_data_2d_3d !> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both !! must have the same array sizes. subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) - type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type - type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + type(coupler_2d_bc_type), intent(in) :: var_in !< A coupler_type structure with data in arbitrary + !! arbitrary units [A] to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< A coupler_type structure with data in arbitrary + !! units [B] whose fields are being incremented integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + !! in arbitrary units [C A-1] real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + !! in arbitrary units [C B-1] call CT_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & scale_prev=scale_prev) @@ -260,11 +265,15 @@ end subroutine CT_increment_data_2d !> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both !! must have the same array sizes. subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) - type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type - type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + type(coupler_3d_bc_type), intent(in) :: var_in !< A coupler_type structure with data in arbitrary + !! arbitrary units [A] to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< A coupler_type structure with data in arbitrary + !! units [B] whose fields are being incremented integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + !! in arbitrary units [C A-1] real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + !! in arbitrary units [C B-1] character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types !! of fluxes to exclude from this increment. character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types @@ -281,7 +290,7 @@ end subroutine CT_increment_data_3d subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to - !! increment the 2d-data. There is no renormalization, + !! increment the 2d-data [nondim]. There is no renormalization, !! so if the weights do not sum to 1 in the 3rd dimension !! there may be adverse consequences! type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented @@ -294,8 +303,11 @@ end subroutine CT_increment_data_2d_3d !> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. !! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. subroutine CT_rescale_data_2d(var, scale) - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled, + !! with the internal data units perhaps changing from + !! arbitrary units [A] to other arbitrary units [B] + real, intent(in) :: scale !< A scaling factor to multiply fields by in + !! arbitrary units [B A-1] call CT_rescale_data(var, scale) @@ -304,8 +316,11 @@ end subroutine CT_rescale_data_2d !> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. !! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. subroutine CT_rescale_data_3d(var, scale) - type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled, + !! with the internal data units perhaps changing from + !! arbitrary units [A] to other arbitrary units [B] + real, intent(in) :: scale !< A scaling factor to multiply fields by in + !! arbitrary units [B A-1] call CT_rescale_data(var, scale) @@ -349,14 +364,17 @@ end subroutine coupler_type_data_override !> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array, using a !! MOM-specific interface. subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, & - halo_size, idim, jdim, field_index) + halo_size, idim, jdim, field_index, turns) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + !! The internal data has arbitrary units [B]. integer, intent(in) :: bc_index !< The index of the boundary condition !! that is being copied - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field in + !! arbitrary units [A]; the size of this array !! must match the size of the data being copied !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being + !! extracted, in arbitrary units [A B-1] integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -367,13 +385,35 @@ subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, integer, optional, intent(in) :: field_index !< The index of the field in the boundary !! condition that is being copied, or the !! surface flux by default. - - if (present(field_index)) then - call CT_extract_data(var_in, bc_index, field_index, array_out, & + integer, optional, intent(in) :: turns !< The number of quarter-turns from the unrotated + !! coupler_2d_bt_type to model grid + + ! Local variables + real, allocatable :: array_unrot(:,:) ! Array on the unrotated grid in arbitrary units [A] + integer :: q_turns ! The number of quarter turns through which array_out is to be rotated + integer :: index, is, ie, js, je, halo + + index = ind_flux ; if (present(field_index)) index = field_index + q_turns = 0 ; if (present(turns)) q_turns = modulo(turns, 4) + halo = 0 ; if (present(halo_size)) halo = halo_size + + ! The case with non-trivial grid rotation is complicated by the fact that the data fields + ! in the coupler_2d_bc_type are never rotated, so they need to be handled separately. + if (q_turns == 0) then + call CT_extract_data(var_in, bc_index, index, array_out, & scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + elseif (present(idim) .and. present(jdim)) then + ! Work only on the computational domain plus symmetric halos. + is = idim(2)-halo ; ie = idim(3)+halo ; js = jdim(2)-halo ; je = jdim(3)+halo + call allocate_rotated_array(array_out(is:ie,js:je), [1,1], -q_turns, array_unrot) + call CT_extract_data(var_in, bc_index, index, array_unrot, scale_factor=scale_factor, halo_size=halo) + call rotate_array(array_unrot, q_turns, array_out(is:ie,js:je)) + deallocate(array_unrot) else - call CT_extract_data(var_in, bc_index, ind_flux, array_out, & - scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + call allocate_rotated_array(array_out, [1,1], -q_turns, array_unrot) + call CT_extract_data(var_in, bc_index, index, array_unrot, scale_factor=scale_factor, halo_size=halo) + call rotate_array(array_unrot, q_turns, array_out) + deallocate(array_unrot) endif end subroutine extract_coupler_type_data @@ -381,17 +421,20 @@ end subroutine extract_coupler_type_data !> Set single 2d field in coupler_2d_bc_type from a two-dimensional array, using a !! MOM-specific interface. subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_factor, & - halo_size, idim, jdim, field_index) - real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + halo_size, idim, jdim, field_index, turns) + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field in + !! arbitrary units [A]; the size of this array !! must match the size of the data being copied !! unless idim and jdim are supplied. integer, intent(in) :: bc_index !< The index of the boundary condition !! that is being copied type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + !! The internal data has arbitrary units [B]. logical, optional, intent(in) :: solubility !< If true and field index is missing, set !! the solubility field. Otherwise set the !! surface concentration (the default). - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being + !! set, in arbitrary units [B A-1] integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -402,15 +445,43 @@ subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_fact integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being set. The !! surface concentration is set by default. + integer, optional, intent(in) :: turns !< The number of quarter-turns from the unrotated + !! coupler_2d_bt_type to model grid + ! Local variables + real, allocatable :: array_unrot(:,:) ! Array on the unrotated grid in the same arbitrary units + ! as array_in [A] integer :: subfield ! An integer indicating which field to set. + integer :: q_turns ! The number of quarter turns through which array_in is rotated + integer :: is, ie, js, je, halo + + q_turns = 0 ; if (present(turns)) q_turns = modulo(turns, 4) subfield = ind_csurf if (present(solubility)) then ; if (solubility) subfield = ind_alpha ; endif if (present(field_index)) subfield = field_index - - call CT_set_data(array_in, bc_index, subfield, var, & - scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + halo = 0 ; if (present(halo_size)) halo = halo_size + + ! The case with non-trivial grid rotation is complicated by the fact that the data fields + ! in the coupler_2d_bc_type are never rotated, so they need to be handled separately. + if (q_turns == 0) then + call CT_set_data(array_in, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + elseif (present(idim) .and. present(jdim)) then + ! Work only on the computational domain plus symmetric halos. + is = idim(2)-halo ; ie = idim(3)+halo ; js = jdim(2)-halo ; je = jdim(3)+halo + call allocate_rotated_array(array_in(is:ie,js:je), [1,1], -q_turns, array_unrot) + call rotate_array(array_in, -q_turns, array_unrot) + call CT_set_data(array_unrot, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size) + deallocate(array_unrot) + else + call allocate_rotated_array(array_in, [1,1], -q_turns, array_unrot) + call rotate_array(array_in, -q_turns, array_unrot) + call CT_set_data(array_in, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size) + deallocate(array_unrot) + endif end subroutine set_coupler_type_data diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 5475e79627..c28e2e5896 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3248,6 +3248,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for diagnostics character(len=8) :: this_pe character(len=240) :: doc_file, doc_file_dflt, doc_path character(len=240), allocatable :: diag_coords(:) @@ -3279,6 +3280,10 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) + call get_param(param_file, mdl, "DIAG_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for diagnostics. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& @@ -3308,7 +3313,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) allocate(diag_cs%diag_remap_cs(diag_cs%num_diag_coords)) ! Initialize each diagnostic vertical coordinate do i=1, diag_cs%num_diag_coords - call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), answer_date=remap_answer_date, GV=GV) + call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), om4_remap_via_sub_cells, remap_answer_date, GV) enddo deallocate(diag_coords) endif diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index bbefa3808b..1151cd04b2 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -92,6 +92,7 @@ module MOM_diag_remap !! vertical extents in [Z ~> m] for remapping extensive variables integer :: interface_axes_id = 0 !< Vertical axes id for remapping at interfaces integer :: layer_axes_id = 0 !< Vertical axes id for remapping on layers + logical :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells integer :: answer_date !< The vintage of the order of arithmetic and expressions !! to use for remapping. Values below 20190101 recover !! the answers from 2018, while higher values use more @@ -102,10 +103,11 @@ module MOM_diag_remap contains !> Initialize a diagnostic remapping type with the given vertical coordinate. -subroutine diag_remap_init(remap_cs, coord_tuple, answer_date, GV) +subroutine diag_remap_init(remap_cs, coord_tuple, om4_remap_via_sub_cells, answer_date, GV) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure character(len=*), intent(in) :: coord_tuple !< A string in form of !! MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME + logical, intent(in) :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells integer, intent(in) :: answer_date !< The vintage of the order of arithmetic and expressions !! to use for remapping. Values below 20190101 recover !! the answers from 2018, while higher values use more @@ -127,6 +129,7 @@ subroutine diag_remap_init(remap_cs, coord_tuple, answer_date, GV) remap_cs%configured = .false. remap_cs%initialized = .false. remap_cs%used = .false. + remap_cs%om4_remap_via_sub_cells = om4_remap_via_sub_cells remap_cs%answer_date = answer_date remap_cs%nz = 0 @@ -309,7 +312,9 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe if (.not. remap_cs%initialized) then ! Initialize remapping and regridding on the first call call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & - answer_date=remap_cs%answer_date) + om4_remap_via_sub_cells=remap_cs%om4_remap_via_sub_cells, & + answer_date=remap_cs%answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) remap_cs%initialized = .true. endif @@ -428,16 +433,9 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere ! Local variables real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] or [Z ~> m] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] or [Z ~> m] integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids integer :: i, j ! Grid index - if (remap_cs%Z_based_coord) then - h_neglect = set_dz_neglect(GV, US, remap_cs%answer_date, h_neglect_edge) - else - h_neglect = set_h_neglect(GV, remap_cs%answer_date, h_neglect_edge) - endif - nz_src = size(field,3) nz_dest = remap_cs%nz remapped_field(:,:,:) = 0. @@ -449,14 +447,14 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & - nz_dest, h_dest(:), remapped_field(I,j,:), h_neglect, h_neglect_edge) + nz_dest, h_dest(:), remapped_field(I,j,:)) endif ; enddo ; enddo else do j=G%jsc,G%jec ; do I=G%IscB,G%IecB h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & - nz_dest, h_dest(:), remapped_field(I,j,:), h_neglect, h_neglect_edge) + nz_dest, h_dest(:), remapped_field(I,j,:)) enddo ; enddo endif elseif (staggered_in_y .and. .not. staggered_in_x) then @@ -466,14 +464,14 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & - nz_dest, h_dest(:), remapped_field(i,J,:), h_neglect, h_neglect_edge) + nz_dest, h_dest(:), remapped_field(i,J,:)) endif ; enddo ; enddo else do J=G%jscB,G%jecB ; do i=G%isc,G%iec h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & - nz_dest, h_dest(:), remapped_field(i,J,:), h_neglect, h_neglect_edge) + nz_dest, h_dest(:), remapped_field(i,J,:)) enddo ; enddo endif elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then @@ -481,14 +479,12 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere if (present(mask)) then do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (mask(i,j) > 0.) then call remapping_core_h(remap_cs%remap_cs, nz_src, h(i,j,:), field(i,j,:), & - nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:), & - h_neglect, h_neglect_edge) + nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:)) endif ; enddo ; enddo else do j=G%jsc,G%jec ; do i=G%isc,G%iec call remapping_core_h(remap_cs%remap_cs, nz_src, h(i,j,:), field(i,j,:), & - nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:), & - h_neglect, h_neglect_edge) + nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:)) enddo ; enddo endif else diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index d937ed7b0c..81e4425be3 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -680,10 +680,10 @@ subroutine write_auto_mask_file(mask_table, layout, npes, filename) true_num_masked_blocks = layout(1) * layout(2) - npes call open_ASCII_file(file_ascii, trim(filename), action=WRITEONLY_FILE) - write(file_ascii, '(I0)'), true_num_masked_blocks - write(file_ascii, '(I0,",",I0)'), layout(1), layout(2) + write(file_ascii, '(I0)') true_num_masked_blocks + write(file_ascii, '(I0,",",I0)') layout(1), layout(2) do p = 1, true_num_masked_blocks - write(file_ascii, '(I0,",",I0)'), mask_table(p,1), mask_table(p,2) + write(file_ascii, '(I0,",",I0)') mask_table(p,1), mask_table(p,2) enddo call close_file(file_ascii) end subroutine write_auto_mask_file diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index ce739cba55..324808e374 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -44,14 +44,15 @@ module MOM_horizontal_regridding contains !> Write to the terminal some basic statistics about the k-th level of an array -subroutine myStats(array, missing, G, k, mesg, scale, full_halo) +subroutine myStats(array, missing, G, k, mesg, unscale, full_halo) type(ocean_grid_type), intent(in) :: G !< Ocean grid type real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: array !< input array in arbitrary units [A ~> a] real, intent(in) :: missing !< missing value in arbitrary units [A ~> a] integer, intent(in) :: k !< Level to calculate statistics for character(len=*), intent(in) :: mesg !< Label to use in message - real, optional, intent(in) :: scale !< A scaling factor for output [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A scaling factor for output that countacts + !! any internal dimesional scaling [a A-1 ~> 1] logical, optional, intent(in) :: full_halo !< If present and true, test values on the whole !! array rather than just the computational domain. ! Local variables @@ -62,7 +63,7 @@ subroutine myStats(array, missing, G, k, mesg, scale, full_halo) logical :: found character(len=120) :: lMesg - scl = 1.0 ; if (present(scale)) scl = scale + scl = 1.0 ; if (present(unscale)) scl = unscale minA = 9.E24 / scl ; maxA = -9.E24 / scl ; found = .false. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -557,7 +558,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr endif if (debug) then - call myStats(tr_inp, missing_value, G, k, 'Tracer from file', scale=I_scale, full_halo=.true.) + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', unscale=I_scale, full_halo=.true.) endif call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value) @@ -585,7 +586,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', scale=I_scale) + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', unscale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions @@ -602,7 +603,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, answer_date=ans_date) if (debug) then - call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', scale=I_scale) + call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', unscale=I_scale) endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) @@ -611,7 +612,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr tr_prev(:,:) = tr_z(:,:,k) if (debug) then - call hchksum(tr_prev, 'field after fill ', G%HI, scale=I_scale) + call hchksum(tr_prev, 'field after fill ', G%HI, unscale=I_scale) endif enddo ! kd @@ -627,7 +628,8 @@ end subroutine horiz_interp_and_extrap_tracer_record subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & z_in, z_edges_in, missing_value, scale, & homogenize, spongeOngrid, m_to_Z, & - answers_2018, tr_iter_tol, answer_date) + answers_2018, tr_iter_tol, answer_date, & + axes) type(external_field), intent(in) :: field !< Handle for the time interpolated field type(time_type), intent(in) :: Time !< A FMS time type @@ -663,6 +665,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & !! Dates before 20190101 give the same answers !! as the code did in late 2018, while later versions !! add parentheses for rotational symmetry. + type(axis_info), allocatable, dimension(:), optional, intent(inout) :: axes !< Axis types for the input data ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the @@ -742,7 +745,16 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & call cpu_clock_begin(id_clock_read) - call get_external_field_info(field, size=fld_sz, axes=axes_data, missing=missing_val_in) + if (present(axes) .and. allocated(axes)) then + call get_external_field_info(field, size=fld_sz, missing=missing_val_in) + axes_data = axes + else + call get_external_field_info(field, size=fld_sz, axes=axes_data, missing=missing_val_in) + if (present(axes)) then + allocate(axes(4)) + axes = axes_data + endif + endif missing_value = scale*missing_val_in verbosity = MOM_get_verbosity() @@ -863,7 +875,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & endif if (debug) then - call myStats(tr_inp, missing_value, G, k, 'Tracer from file', scale=I_scale, full_halo=.true.) + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', unscale=I_scale, full_halo=.true.) endif tr_out(:,:) = 0.0 @@ -891,7 +903,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', scale=I_scale) + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', unscale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions @@ -909,8 +921,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, answer_date=ans_date) ! if (debug) then -! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, scale=I_scale) -! call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', scale=I_scale) +! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, unscale=I_scale) +! call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', unscale=I_scale) ! endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) @@ -918,7 +930,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & tr_prev(:,:) = tr_z(:,:,k) if (debug) then - call hchksum(tr_prev, 'field after fill ', G%HI, scale=I_scale) + call hchksum(tr_prev, 'field after fill ', G%HI, unscale=I_scale) endif enddo ! kd diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index ae0a68df5f..fdafa8503d 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -117,9 +117,9 @@ end function cuberoot !> Rescale `a` to the range [0.125, 1) and compute its cube-root exponent. pure subroutine rescale_cbrt(a, x, e_r, s_a) real, intent(in) :: a - !< The real parameter to be rescaled for cube root + !< The real parameter to be rescaled for cube root in abitrary units cubed [A3] real, intent(out) :: x - !< The rescaled value of a + !< The rescaled value of a in the range from 0.125 < asx <= 1.0, in ambiguous units cubed [B3] integer(kind=int64), intent(out) :: e_r !< Cube root of the exponent of the rescaling of `a` integer(kind=int64), intent(out) :: s_a @@ -162,13 +162,13 @@ end subroutine rescale_cbrt !> Undo the rescaling of a real number back to its original base. pure function descale(x, e_a, s_a) result(a) real, intent(in) :: x - !< The rescaled value which is to be restored. + !< The rescaled value which is to be restored in ambiguous units [B] integer(kind=int64), intent(in) :: e_a !< Exponent of the unscaled value integer(kind=int64), intent(in) :: s_a !< Sign bit of the unscaled value real :: a - !< Restored value with the corrected exponent and sign + !< Restored value with the corrected exponent and sign in abitrary units [A] integer(kind=int64) :: xb ! Bit-packed real number into integer form @@ -176,7 +176,7 @@ pure function descale(x, e_a, s_a) result(a) ! Biased exponent of x ! Apply the corrected exponent and sign to x. - xb = transfer(x, 1_8) + xb = transfer(x, 1_int64) e_x = ibits(xb, expbit, explen) call mvbits(e_a + e_x, 0, explen, xb, expbit) call mvbits(s_a, 0, 1, xb, signbit) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 27d244b226..8ee192323a 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -2504,7 +2504,7 @@ end subroutine MOM_read_vector_3d !> Write a 4d field to an output file, potentially with rotation subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition @@ -2516,7 +2516,13 @@ subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tst real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before !! it is written [a A-1 ~> 1], for example to convert it !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units [a] or ! rescaled [A ~> a] then [a] real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] @@ -2524,6 +2530,7 @@ subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tst qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & @@ -2541,7 +2548,7 @@ end subroutine MOM_write_field_legacy_4d !> Write a 3d field to an output file, potentially with rotation subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition @@ -2553,8 +2560,13 @@ subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tst real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before !! it is written [a A-1 ~> 1], for example to convert it !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - + ! Local variables real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units [a] or ! rescaled [A ~> a] then [a] real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] @@ -2562,6 +2574,7 @@ subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tst qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & @@ -2579,7 +2592,7 @@ end subroutine MOM_write_field_legacy_3d !> Write a 2d field to an output file, potentially with rotation subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition @@ -2591,8 +2604,13 @@ subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tst real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before !! it is written [a A-1 ~> 1], for example to convert it !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - + ! Local variables real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units [a] or ! rescaled [A ~> a] then [a] real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] @@ -2600,6 +2618,7 @@ subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tst qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & @@ -2616,7 +2635,7 @@ end subroutine MOM_write_field_legacy_2d !> Write a 1d field to an output file -subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, dimension(:), intent(in) :: field !< Field to write in arbitrary units [A ~> a] @@ -2625,13 +2644,19 @@ subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_va real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before !! it is written [a A-1 ~> 1], for example to convert it !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - + ! Local variables real, dimension(:), allocatable :: array ! A rescaled copy of field [a] real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: i scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if (scale_fac == 1.0) then call write_field(IO_handle, field_md, field, tstamp=tstamp) @@ -2648,7 +2673,7 @@ end subroutine MOM_write_field_legacy_1d !> Write a 0d field to an output file -subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, intent(in) :: field !< Field to write in arbitrary units [A ~> a] @@ -2657,11 +2682,21 @@ subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_va real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before !! it is written [a A-1 ~> 1], for example to convert it !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables + real :: scale_fac ! A scaling factor to use before writing the field [a A-1 ~> 1] real :: scaled_val ! A rescaled copy of field [a] - scaled_val = field - if (present(scale)) scaled_val = scale*field + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + scaled_val = field * scale_fac + if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif call write_field(IO_handle, field_md, scaled_val, tstamp=tstamp) @@ -2670,24 +2705,32 @@ end subroutine MOM_write_field_legacy_0d !> Write a 4d field to an output file, potentially with rotation subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(MOM_field), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) - real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: fill_value !< Missing data fill value [a] integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units or rescaled - real :: scale_fac ! A scaling factor to use before writing the array + ! Local variables + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units or rescaled [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & @@ -2704,24 +2747,32 @@ end subroutine MOM_write_field_4d !> Write a 3d field to an output file, potentially with rotation subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(MOM_field), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) - real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: fill_value !< Missing data fill value [a] integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units or rescaled - real :: scale_fac ! A scaling factor to use before writing the array + ! Local variables + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units or rescaled [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & @@ -2738,24 +2789,32 @@ end subroutine MOM_write_field_3d !> Write a 2d field to an output file, potentially with rotation subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(MOM_field), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) - real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: fill_value !< Missing data fill value [a] integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units - real :: scale_fac ! A scaling factor to use before writing the array + ! Local variables + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units or rescaled [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & @@ -2771,20 +2830,28 @@ subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, ti end subroutine MOM_write_field_2d !> Write a 1d field to an output file -subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(MOM_field), intent(in) :: field_md !< Field type with metadata - real, dimension(:), intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, dimension(:), intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, dimension(:), allocatable :: array ! A rescaled copy of field - real :: scale_fac ! A scaling factor to use before writing the array + ! Local variables + real, dimension(:), allocatable :: array ! A rescaled copy of field in arbtrary unscaled units [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: i scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if (scale_fac == 1.0) then call IO_handle%write_field(field_md, field, tstamp=tstamp) @@ -2800,18 +2867,30 @@ subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, sc end subroutine MOM_write_field_1d !> Write a 0d field to an output file -subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(MOM_field), intent(in) :: field_md !< Field type with metadata - real, intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written - real :: scaled_val ! A rescaled copy of field + real, intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + + ! Local variables + real :: scale_fac ! A scaling factor to use before writing the field [a A-1 ~> 1] + real :: scaled_val ! A rescaled copy of field in arbtrary unscaled units [a] + + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + scaled_val = field * scale_fac - scaled_val = field - if (present(scale)) scaled_val = scale*field if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif call IO_handle%write_field(field_md, scaled_val, tstamp=tstamp) diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index f5e996d3e4..6fcc6903c9 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -99,7 +99,7 @@ end function random_norm subroutine random_2d_01(CS, HI, rand) type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators type(hor_index_type), intent(in) :: HI !< Horizontal index structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 [nondim] ! Local variables integer :: i,j @@ -116,7 +116,7 @@ end subroutine random_2d_01 subroutine random_2d_norm(CS, HI, rand) type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators type(hor_index_type), intent(in) :: HI !< Horizontal index structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 [nondim] ! Local variables integer :: i,j,n @@ -318,14 +318,14 @@ logical function random_unit_tests(verbose) ! Local variables type(PRNG) :: test_rng ! Generator type(time_type) :: Time ! Model time - real :: r1, r2, r3 ! Some random numbers and re-used work variables - real :: mean, var, ar1, std ! Some statistics + real :: r1, r2, r3 ! Some random numbers and re-used work variables [nondim] + real :: mean, var, ar1, std ! Some statistics [nondim] integer :: stdunit ! For messages integer, parameter :: n_samples = 800 integer :: i, j, ni, nj ! Fake being on a decomposed domain type(hor_index_type), pointer :: HI => null() !< Not the real HI - real, dimension(:,:), allocatable :: r2d ! Random numbers + real, dimension(:,:), allocatable :: r2d ! Random numbers [nondim] ! Fake a decomposed domain ni = 6 @@ -547,7 +547,7 @@ logical function test_fn(verbose, good, label, rvalue, ivalue) logical, intent(in) :: verbose !< Verbosity logical, intent(in) :: good !< True if pass, false otherwise character(len=*), intent(in) :: label !< Label for messages - real, intent(in) :: rvalue !< Result of calculation + real, intent(in) :: rvalue !< Result of calculation [nondim] integer, intent(in) :: ivalue !< Result of calculation optional :: rvalue, ivalue diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 06f4abc065..8152564b4f 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -3,6 +3,7 @@ module MOM_restart ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : int64 use MOM_checksums, only : chksum => rotated_field_chksum use MOM_domains, only : PE_here, num_PEs, AGRID, BGRID_NE, CGRID_NE use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe @@ -1348,12 +1349,12 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ character(len=256) :: restartname ! The restart file name (no dir). character(len=8) :: suffix ! A suffix (like _2) that is appended ! to the name of files after the first. - integer(kind=8) :: var_sz, size_in_file ! The size in bytes of each variable + integer(kind=int64) :: var_sz, size_in_file ! The size in bytes of each variable ! and the variables already in a file. - integer(kind=8), parameter :: max_file_size = 4294967292_8 ! The maximum size in bytes for the + integer(kind=int64), parameter :: max_file_size = 4294967292_int64 ! The maximum size in bytes for the ! starting position of each variable in a file's record, ! based on the use of NetCDF 3.6 or later. For earlier - ! versions of NetCDF, the value was 2147483647_8. + ! versions of NetCDF, the value was 2147483647_int64. integer :: start_var, next_var ! The starting variables of the ! current and next files. type(MOM_infra_file) :: IO_handle ! The I/O handle of the open fileset @@ -1365,7 +1366,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ real :: restart_time ! The model time at whic the restart file is being written [days] character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs integer :: length ! The length of a text string. - integer(kind=8) :: check_val(CS%max_fields,1) + integer(kind=int64) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos integer :: turns integer, parameter :: nmax_extradims = 5 @@ -1512,19 +1513,19 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ do m=start_var,next_var-1 if (associated(CS%var_ptr3d(m)%p)) then call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr3d(m)%p, & - restart_time, scale=CS%restart_field(m)%conv, turns=-turns) + restart_time, unscale=CS%restart_field(m)%conv, turns=-turns) elseif (associated(CS%var_ptr2d(m)%p)) then call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr2d(m)%p, & - restart_time, scale=CS%restart_field(m)%conv, turns=-turns) + restart_time, unscale=CS%restart_field(m)%conv, turns=-turns) elseif (associated(CS%var_ptr4d(m)%p)) then call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr4d(m)%p, & - restart_time, scale=CS%restart_field(m)%conv, turns=-turns) + restart_time, unscale=CS%restart_field(m)%conv, turns=-turns) elseif (associated(CS%var_ptr1d(m)%p)) then call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr1d(m)%p, & - restart_time, scale=CS%restart_field(m)%conv) + restart_time, unscale=CS%restart_field(m)%conv) elseif (associated(CS%var_ptr0d(m)%p)) then call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr0d(m)%p, & - restart_time, scale=CS%restart_field(m)%conv) + restart_time, unscale=CS%restart_field(m)%conv) endif enddo @@ -1570,8 +1571,8 @@ subroutine restore_state(filename, directory, day, G, CS) real, allocatable :: time_vals(:) ! Times from a file extracted with getl_file_times [days] type(MOM_field), allocatable :: fields(:) logical :: is_there_a_checksum ! Is there a valid checksum that should be checked. - integer(kind=8) :: checksum_file ! The checksum value recorded in the input file. - integer(kind=8) :: checksum_data ! The checksum value for the data that was read in. + integer(kind=int64) :: checksum_file ! The checksum value recorded in the input file. + integer(kind=int64) :: checksum_data ! The checksum value for the data that was read in. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "restore_state: Module must be initialized before it is used.") @@ -2182,7 +2183,7 @@ function get_variable_byte_size(hor_grid, z_grid, t_grid, G, num_z) result(var_s character(len=8), intent(in) :: t_grid !< A time string to interpret type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure integer, intent(in) :: num_z !< The number of vertical layers in the grid - integer(kind=8) :: var_sz !< The function result, the size in bytes of a variable + integer(kind=int64) :: var_sz !< The function result, the size in bytes of a variable ! Local variables integer :: var_periods ! The number of entries in a time-periodic axis diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 index 1087958939..a9829c510e 100644 --- a/src/framework/posix.F90 +++ b/src/framework/posix.F90 @@ -437,6 +437,7 @@ function setjmp_missing(env) result(rc) bind(c) error stop ! NOTE: compilers may expect a return value, even if it is unreachable + read env%state rc = -1 end function setjmp_missing @@ -450,6 +451,9 @@ subroutine longjmp_missing(env, val) bind(c) print '(a)', 'ERROR: longjmp() is not implemented in this build.' print '(a)', 'Recompile with autoconf or -DLONGJMP_NAME=\"\".' error stop + + read env%state + read char(val) end subroutine longjmp_missing !> Placeholder function for a missing or unconfigured sigsetjmp @@ -466,6 +470,8 @@ function sigsetjmp_missing(env, savesigs) result(rc) bind(c) error stop ! NOTE: compilers may expect a return value, even if it is unreachable + read env%state + read char(savesigs) rc = -1 end function sigsetjmp_missing @@ -478,6 +484,8 @@ subroutine siglongjmp_missing(env, val) bind(c) print '(a)', 'ERROR: siglongjmp() is not implemented in this build.' print '(a)', 'Recompile with autoconf or -DSIGLONGJMP_NAME=\"\".' + read env%state + read char(val) error stop end subroutine siglongjmp_missing diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index b9640502d2..bac5b0fce9 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -8,11 +8,12 @@ module MOM_ice_shelf use MOM_constants, only : hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE -use MOM_coms, only : num_PEs +use MOM_coms, only : num_PEs, reproducing_sum use MOM_data_override, only : data_override use MOM_diag_mediator, only : MOM_diag_ctrl=>diag_ctrl -use MOM_IS_diag_mediator, only : post_data=>post_IS_data +use MOM_IS_diag_mediator, only : post_data=>post_IS_data, post_scalar_data=>post_IS_data_0d use MOM_IS_diag_mediator, only : register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr +use MOM_IS_diag_mediator, only : register_scalar_field=>register_MOM_IS_scalar_field use MOM_IS_diag_mediator, only : set_IS_axes_info, diag_ctrl, time_type use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end use MOM_IS_diag_mediator, only : set_IS_diag_mediator_grid @@ -23,6 +24,8 @@ module MOM_ice_shelf use MOM_domains, only : TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_grid_initialize, only : set_grid_metrics @@ -38,12 +41,12 @@ module MOM_ice_shelf use MOM_restart, only : restart_init, restore_state, MOM_restart_CS, register_restart_pair use MOM_time_manager, only : time_type, time_type_to_real, real_to_time, operator(>), operator(-) use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid -use MOM_transcribe_grid, only : rotate_dyngrid +use MOM_transcribe_grid, only : rotate_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling -use MOM_variables, only : surface, allocate_surface_state +use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : rotate_surface_state -use MOM_forcing_type, only : forcing, allocate_forcing_type, MOM_forcing_chksum -use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum +use MOM_forcing_type, only : forcing, allocate_forcing_type, deallocate_forcing_type, MOM_forcing_chksum +use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, deallocate_mech_forcing, MOM_mech_forcing_chksum use MOM_forcing_type, only : copy_common_forcing_fields, rotate_forcing, rotate_mech_forcing use MOM_get_input, only : directories, Get_MOM_input use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze, EOS_domain @@ -51,13 +54,13 @@ module MOM_ice_shelf use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf, write_ice_shelf_energy use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve, change_in_draft -use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end +use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end, IS_dynamics_post_data +use MOM_ice_shelf_dynamics, only : volume_above_floatation, masked_var_grounded use MOM_ice_shelf_initialize, only : initialize_ice_thickness !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary use MOM_ice_shelf_state, only : ice_shelf_state, ice_shelf_state_end, ice_shelf_state_init use user_shelf_init, only : USER_initialize_shelf_mass, USER_update_shelf_mass use user_shelf_init, only : user_ice_shelf_CS -use MOM_coms, only : reproducing_sum use MOM_spatial_means, only : global_area_integral use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init @@ -75,6 +78,7 @@ module MOM_ice_shelf public shelf_calc_flux, initialize_ice_shelf, ice_shelf_end, ice_shelf_query public ice_shelf_save_restart, solo_step_ice_shelf, add_shelf_forces public initialize_ice_shelf_fluxes, initialize_ice_shelf_forces +public ice_sheet_calving_to_ocean_sfc ! 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 @@ -87,10 +91,6 @@ module MOM_ice_shelf type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control !! structure for the ice shelves type(ocean_grid_type), pointer :: Grid_in => NULL() !< un-rotated input grid metric - type(hor_index_type), pointer :: HI_in => NULL() !< Pointer to a horizontal indexing structure for - !! incoming data which has not been rotated. - type(hor_index_type), pointer :: HI => NULL() !< Pointer to a horizontal indexing structure for - !! incoming data which has not been rotated. logical :: rotate_index = .false. !< True if index map is rotated integer :: turns !< The number of quarter turns for rotation testing. type(ocean_grid_type), pointer :: Grid => NULL() !< Grid for the ice-shelf model @@ -151,6 +151,8 @@ module MOM_ice_shelf !! will be called (note: GL_regularize and GL_couple !! should be exclusive) logical :: calve_to_mask !< If true, calve any ice that passes outside of a masked area + logical :: calve_ice_shelf_bergs=.false. !< If true, flux through a static ice front is converted + !! to point bergs real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. real :: T0 !< temperature at ocean surface in the restoring region [C ~> degC] real :: S0 !< Salinity at ocean surface in the restoring region [S ~> ppt]. @@ -179,6 +181,8 @@ module MOM_ice_shelf !! fluxes. It will avoid large increase in sea level. logical :: constant_sea_level_misomip !< If true, constant_sea_level fluxes are applied only over !! the surface sponge cells from the ISOMIP/MISOMIP configuration + logical :: smb_diag !< If true, calculate diagnostics related to surface mass balance + logical :: bmb_diag !< If true, calculate diagnostics related to basal mass balance real :: min_ocean_mass_float !< The minimum ocean mass per unit area before the ice !! shelf is considered to float when constant_sea_level !! is used [R Z ~> kg m-2] @@ -206,7 +210,22 @@ module MOM_ice_shelf id_surf_elev = -1, id_bathym = -1, & id_area_shelf_h = -1, & id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1, & - id_shelf_sfc_mass_flux = -1 + id_shelf_sfc_mass_flux = -1, & + id_vaf = -1, id_g_adott = -1, id_f_adott = -1, id_adott = -1, & + id_bdott_melt = -1, id_bdott_accum = -1, id_bdott = -1, & + id_dvafdt = -1, id_g_adot = -1, id_f_adot = -1, id_adot = -1, & + id_bdot_melt = -1, id_bdot_accum = -1, id_bdot = -1, & + id_t_area = -1, id_g_area = -1, id_f_area = -1, & + id_Ant_vaf = -1, id_Ant_g_adott = -1, id_Ant_f_adott = -1, id_Ant_adott = -1, & + id_Ant_bdott_melt = -1, id_Ant_bdott_accum = -1, id_Ant_bdott = -1, & + id_Ant_dvafdt = -1, id_Ant_g_adot = -1, id_Ant_f_adot = -1, id_Ant_adot = -1, & + id_Ant_bdot_melt = -1, id_Ant_bdot_accum = -1, id_Ant_bdot = -1, & + id_Ant_t_area = -1, id_Ant_g_area = -1, id_Ant_f_area = -1, & + id_Gr_vaf = -1, id_Gr_g_adott = -1, id_Gr_f_adott = -1, id_Gr_adott = -1, & + id_Gr_bdott_melt = -1, id_Gr_bdott_accum = -1, id_Gr_bdott = -1, & + id_Gr_dvafdt = -1, id_Gr_g_adot = -1, id_Gr_f_adot = -1, id_Gr_adot = -1, & + id_Gr_bdot_melt = -1, id_Gr_bdot_accum = -1, id_Gr_bdot = -1, & + id_Gr_t_area = -1, id_Gr_g_area = -1, id_Gr_f_area = -1 !>@} type(external_field) :: mass_handle @@ -263,9 +282,10 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) p_int !< The pressure at the ice-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & - exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] - exch_vel_s !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] - + exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] + exch_vel_s, & !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] + dh_bdott, & !< Basal melt/accumulation over a time step, used for diagnostics [Z ~> m] + dh_adott !< Surface melt/accumulation over a time step, used for diagnostics [Z ~> m] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & mass_flux !< Total mass flux of freshwater across the ice-ocean interface. [R Z L2 T-1 ~> kg s-1] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & @@ -333,6 +353,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) character(len=160) :: mesg ! The text of an error message integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, ied, jed, it1, it3 + real :: vaf0, vaf0_A, vaf0_G !The previous volumes above floatation [m3] + !for all ice sheets, Antarctica only, or Greenland only [m3] if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & "initialize_ice_shelf must be called before shelf_calc_flux.") @@ -341,24 +363,35 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) G => CS%grid ; US => CS%US ISS => CS%ISS time_step = time_step_in + Itime_step = 1./time_step + + dh_adott(:,:)=0.0; dh_bdott(:,:)=0.0 + + if (CS%active_shelf_dynamics) then + !calculate previous volumes above floatation + if (CS%id_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0) !all ice sheet + if (CS%id_Ant_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_A, hemisphere=0) !Antarctica only + if (CS%id_Gr_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_G, hemisphere=1) !Greenland only + endif + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed if (CS%data_override_shelf_fluxes .and. CS%active_shelf_dynamics) then - call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux, CS%Time, & + call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux(is:ie,js:je), CS%Time, & scale=US%kg_m2s_to_RZ_T) + call pass_var(fluxes_in%shelf_sfc_mass_flux, G%domain, complete=.true.) endif if (CS%rotate_index) then allocate(sfc_state) call rotate_surface_state(sfc_state_in, sfc_state, CS%Grid, CS%turns) allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=CS%turns) call rotate_forcing(fluxes_in, fluxes, CS%turns) else sfc_state => sfc_state_in fluxes => fluxes_in endif ! useful parameters - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed ZETA_N = CS%Zeta_N VK = CS%Vk RC = CS%Rc @@ -395,12 +428,12 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (CS%debug) then call hchksum(fluxes_in%frac_shelf_h, "frac_shelf_h before apply melting", CS%Grid_in%HI, haloshift=0) - call hchksum(sfc_state_in%sst, "sst before apply melting", CS%Grid_in%HI, haloshift=0, scale=US%C_to_degC) - call hchksum(sfc_state_in%sss, "sss before apply melting", CS%Grid_in%HI, haloshift=0, scale=US%S_to_ppt) + call hchksum(sfc_state_in%sst, "sst before apply melting", CS%Grid_in%HI, haloshift=0, unscale=US%C_to_degC) + call hchksum(sfc_state_in%sss, "sss before apply melting", CS%Grid_in%HI, haloshift=0, unscale=US%S_to_ppt) call uvchksum("[uv]_ml before apply melting", sfc_state_in%u, sfc_state_in%v, & - CS%Grid_in%HI, haloshift=0, scale=US%L_T_to_m_s) + CS%Grid_in%HI, haloshift=0, unscale=US%L_T_to_m_s) call hchksum(sfc_state_in%ocean_mass, "ocean_mass before apply melting", CS%Grid_in%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) + unscale=US%RZ_to_kg_m2) endif ! Calculate the friction velocity under ice shelves, using taux_shelf and tauy_shelf if possible. @@ -417,11 +450,11 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) I_au = 0.0 ; if (asu1 + asu2 > 0.0) I_au = 1.0 / (asu1 + asu2) I_av = 0.0 ; if (asv1 + asv2 > 0.0) I_av = 1.0 / (asv1 + asv2) if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then - taux2 = (asu1 * sfc_state%taux_shelf(I-1,j)**2 + asu2 * sfc_state%taux_shelf(I,j)**2 ) * I_au - tauy2 = (asv1 * sfc_state%tauy_shelf(i,J-1)**2 + asv2 * sfc_state%tauy_shelf(i,J)**2 ) * I_av + taux2 = (((asu1 * (sfc_state%taux_shelf(I-1,j)**2)) + (asu2 * (sfc_state%taux_shelf(I,j)**2)) ) * I_au) + tauy2 = (((asv1 * (sfc_state%tauy_shelf(i,J-1)**2)) + (asv2 * (sfc_state%tauy_shelf(i,J)**2)) ) * I_av) endif - u2_av = (asu1 * sfc_state%u(I-1,j)**2 + asu2 * sfc_state%u(I,j)**2) * I_au - v2_av = (asv1 * sfc_state%v(i,J-1)**2 + asu2 * sfc_state%v(i,J)**2) * I_av + u2_av = (((asu1 * (sfc_state%u(I-1,j)**2)) + (asu2 * sfc_state%u(I,j)**2)) * I_au) + v2_av = (((asv1 * (sfc_state%v(i,J-1)**2)) + (asu2 * sfc_state%v(i,J)**2)) * I_av) if ((taux2 + tauy2 > 0.0) .and. .not.CS%ustar_shelf_from_vel) then if (CS%ustar_max >= 0.0) then @@ -743,12 +776,14 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ! Melting has been computed, now is time to update thickness and mass if ( CS%override_shelf_movement .and. (.not.CS%mass_from_file)) then + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) if (CS%debug) then - call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, unscale=US%Z_to_m) call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) + unscale=US%RZ_to_kg_m2) endif endif @@ -757,20 +792,24 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) if (CS%debug) then - call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, unscale=US%Z_to_m) call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) + unscale=US%RZ_to_kg_m2) endif + if (CS%smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time) + if (CS%smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je) if (CS%debug) then - call hchksum(ISS%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, unscale=US%Z_to_m) call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using surf acc", G%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) + unscale=US%RZ_to_kg_m2) endif update_ice_vel = .false. @@ -778,17 +817,18 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. ! when we decide on how to do it - call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, & + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, CS%calve_ice_shelf_bergs, & sfc_state%ocean_mass, coupled_GL) - Itime_step = 1./time_step do j=js,je ; do i=is,ie ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j))*Itime_step enddo; enddo + + call IS_dynamics_post_data(time_step, Time, CS%dCS, ISS, G) endif if (CS%shelf_mass_is_dynamic) & - call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, ISS%area_shelf_h, Time, & time_step=real_to_time(US%T_to_s*time_step) ) if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) @@ -816,20 +856,88 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) + call process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh_adott, dh_bdott) call disable_averaging(CS%diag) - call cpu_clock_end(id_clock_shelf) + if (CS%debug) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, CS%US, haloshift=0) + if (CS%rotate_index) then ! call rotate_surface_state(sfc_state, sfc_state_in, CS%Grid_in, -CS%turns) - call rotate_forcing(fluxes,fluxes_in,-CS%turns) + call rotate_forcing(fluxes, fluxes_in, -CS%turns) + call deallocate_surface_state(sfc_state) + deallocate(sfc_state) + call deallocate_forcing_type(fluxes) + deallocate(fluxes) endif +end subroutine shelf_calc_flux - if (CS%debug) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, CS%US, haloshift=0) +subroutine integrate_over_ice_sheet_area(G, ISS, var, var_scale, var_out, hemisphere) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe the ice-shelf state + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< Ice variable to integrate in arbitrary units [A ~> a] + real, intent(in) :: var_scale !< Dimensional scaling for variable to integrate [a A-1 ~> 1] + real, intent(out) :: var_out !< Variable integrated over the area of the ice sheet in arbitrary units [a m2] + integer, optional, intent(in) :: hemisphere !< 0 for Antarctica only, 1 for Greenland only. Otherwise, all ice sheets + integer :: IS_ID ! local copy of hemisphere + real, dimension(SZI_(G),SZJ_(G)) :: var_cell !< Variable integrated over the ice-sheet area of each cell + !! in arbitrary units [a m2] + integer, dimension(SZI_(G),SZJ_(G)) :: mask ! a mask for active cells depending on hemisphere indicated + integer :: i,j + + if (present(hemisphere)) then + IS_ID=hemisphere + else + IS_ID=-1 + endif -end subroutine shelf_calc_flux + mask(:,:)=0 + if (IS_ID==0) then !Antarctica (S. Hemisphere) only + do j = G%jsc,G%jec; do i = G%isc,G%iec + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)<=0.0) mask(i,j)=1 + enddo; enddo + elseif (IS_ID==1) then !Greenland (N. Hemisphere) only + do j = G%jsc,G%jec; do i = G%isc,G%iec + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)>0.0) mask(i,j)=1 + enddo; enddo + else !All ice sheets + mask(G%isc:G%iec,G%jsc:G%jec)=ISS%hmask(G%isc:G%iec,G%jsc:G%jec) + endif + + var_cell(:,:)=0.0 + do j = G%jsc,G%jec; do i = G%isc,G%iec + if (mask(i,j)>0) var_cell(i,j) = (var(i,j) * var_scale) * (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) + enddo; enddo + + var_out = reproducing_sum(var_cell) +end subroutine integrate_over_ice_sheet_area + +!> Converts the ice-shelf-to-ocean calving and calving_hflx variables from the ice-shelf state (ISS) type +!! to the ocean public type +subroutine ice_sheet_calving_to_ocean_sfc(CS,US,calving,calving_hflx) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(:,:), intent(inout) :: calving !< The mass flux per unit area of the ice shelf + !! to convert to bergs [R Z T-1 ~> kg m-2 s-1]. + real, dimension(:,:), intent(inout) :: calving_hflx !< Calving heat flux [Q R Z T-1 ~> W m-2]. + ! Local variables + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), pointer :: G => NULL() !< A pointer to the ocean grid metric. + integer :: is, ie, js, je + + G=>CS%Grid + ISS => CS%ISS + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + calving = US%RZ_T_to_kg_m2s * ISS%calving(is:ie,js:je) + calving_hflx = US%QRZ_T_to_W_m2 * ISS%calving_hflx(is:ie,js:je) + + !CS%calve_ice_shelf_bergs=.true. + +end subroutine ice_sheet_calving_to_ocean_sfc !> Changes the thickness (mass) of the ice shelf based on sub-ice-shelf melting subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ice, debug) @@ -867,7 +975,7 @@ subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ic ISS%hmask(i,j) = 0.0 ISS%area_shelf_h(i,j) = 0.0 endif - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * density_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * density_ice endif enddo ; enddo @@ -880,18 +988,18 @@ end subroutine change_thickness_using_melt !> This subroutine adds the mechanical forcing fields and perhaps shelf areas, based on !! the ice state in ice_shelf_CS. -subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_call) +subroutine add_shelf_forces(Ocn_grid, US, CS, forces_in, do_shelf_area, external_call) type(ocean_grid_type), intent(in) :: Ocn_grid !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), pointer :: CS !< This module's control structure. - type(mech_forcing), intent(inout) :: forces !< A structure with the + type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the !! driving mechanical forces logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. logical, optional, intent(in) :: external_call !< If true the incoming forcing type - !! is using the input grid metric and needs + !! is using the unrotated input grid and may need !! to be rotated. type(ocean_grid_type), pointer :: G => NULL() !< A pointer to the ocean grid metric. -! type(mech_forcing), target :: forces !< A structure with the driving mechanical forces + type(mech_forcing), pointer :: forces !< A structure with the driving mechanical forces real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 T-1 R-1 Z-2 ~> m5 kg-1 s-1]. real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. logical :: find_area ! If true find the shelf areas at u & v points. @@ -901,29 +1009,25 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - if (present(external_call)) rotate=external_call - - if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & - (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & - call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + rotate = .false. ; if (present(external_call)) rotate = external_call if (CS%rotate_index .and. rotate) then - call MOM_error(FATAL,"add_shelf_forces: Rotation not implemented for ice shelves.") - ! allocate(forces) - ! call allocate_mech_forcing(forces_in, CS%Grid, forces) - ! call rotate_mech_forcing(forces_in, CS%turns, forces) - ! else - ! if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & - ! (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & - ! call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and external Ice shelf grids.") + allocate(forces) + call allocate_mech_forcing(forces_in, CS%Grid, forces) + call rotate_mech_forcing(forces_in, CS%turns, forces) + else + if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & + (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and internal Ice shelf grids.") - ! forces=>forces_in + forces=>forces_in endif G=>CS%Grid - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed @@ -979,16 +1083,16 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca if (CS%debug) then call uvchksum("rigidity_ice_[uv]", forces%rigidity_ice_u, & forces%rigidity_ice_v, CS%Grid%HI, symmetric=.true., & - scale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) + unscale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) call uvchksum("frac_shelf_[uv]", forces%frac_shelf_u, & forces%frac_shelf_v, CS%Grid%HI, symmetric=.true., & scalar_pair=.true.) endif - ! if (CS%rotate_index .and. rotate) then - ! call rotate_mech_forcing(forces, -CS%turns, forces_in) - ! ! TODO: deallocate mech forcing? - ! endif + if (CS%rotate_index .and. rotate) then + call rotate_mech_forcing(forces, -CS%turns, forces_in) + call deallocate_mech_forcing(forces) + endif end subroutine add_shelf_forces @@ -1078,7 +1182,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) if (CS%debug) then if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then call uvchksum("tau[xy]_shelf", sfc_state%taux_shelf, sfc_state%tauy_shelf, & - G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + G%HI, haloshift=0, unscale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) endif endif @@ -1123,8 +1227,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) endif ; enddo ; enddo if (CS%debug) then - call hchksum(ISS%water_flux, "water_flux add shelf fluxes", G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s) - call hchksum(ISS%tflux_ocn, "tflux_ocn add shelf fluxes", G%HI, haloshift=0, scale=US%QRZ_T_to_W_m2) + call hchksum(ISS%water_flux, "water_flux add shelf fluxes", G%HI, haloshift=0, unscale=US%RZ_T_to_kg_m2s) + call hchksum(ISS%tflux_ocn, "tflux_ocn add shelf fluxes", G%HI, haloshift=0, unscale=US%QRZ_T_to_W_m2) call MOM_forcing_chksum("After adding shelf fluxes", fluxes, G, CS%US, haloshift=0) endif @@ -1243,7 +1347,7 @@ end subroutine add_shelf_flux !> Initializes shelf model data, parameters and diagnostics subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, directory, forces_in, & - fluxes_in, sfc_state_in, solo_ice_sheet_in) + fluxes_in, sfc_state_in, solo_ice_sheet_in, calve_ice_shelf_bergs) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time @@ -1261,6 +1365,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, !! intent is only inout to allow for halo updates. logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether !! a solo ice-sheet driver. + logical, optional :: calve_ice_shelf_bergs !< If true, will add point iceberg calving variables to the ice + !! shelf restart type(ocean_grid_type), pointer :: G => NULL(), OG => NULL() ! Pointers to grids for convenience. type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing @@ -1269,6 +1375,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, !! the ice-shelf state type(directories) :: dirs type(dyn_horgrid_type), pointer :: dG => NULL() + type(dyn_horgrid_type), pointer :: dG_in => NULL() real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered ! to be floating when CONST_SEA_LEVEL = True [Z ~> m]. @@ -1280,6 +1387,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) + logical :: showCallTree logical :: read_TideAmp, debug logical :: global_indexing character(len=240) :: Tideamp_file ! Input file names @@ -1321,55 +1429,57 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, ! Set up the ice-shelf domain and grid wd_halos(:)=0 - allocate(CS%Grid) - call MOM_domains_init(CS%Grid%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& + allocate(CS%Grid_in) + call MOM_domains_init(CS%Grid_in%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& domain_name='MOM_Ice_Shelf_in', US=CS%US) !allocate(CS%Grid_in%HI) !call hor_index_init(CS%Grid%Domain, CS%Grid%HI, param_file, & ! local_indexing=.not.global_indexing) - call MOM_grid_init(CS%Grid, param_file, CS%US) + call MOM_grid_init(CS%Grid_in, param_file, CS%US) - ! if (CS%rotate_index) then + if (CS%rotate_index) then ! ! TODO: Index rotation currently only works when index rotation does not ! ! change the MPI rank of each domain. Resolving this will require a ! ! modification to FMS PE assignment. ! ! For now, we only permit single-core runs. - ! if (num_PEs() /= 1) & - ! call MOM_error(FATAL, "Index rotation is only supported on one PE.") - - ! call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & - ! "Number of counterclockwise quarter-turn index rotations.", & - ! default=1, debuggingParam=.true.) - ! ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. - ! ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. - ! allocate(CS%Grid) - ! !allocate(CS%HI) - ! call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain,turns=CS%turns) - ! call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) - ! call MOM_grid_init(CS%Grid, param_file, CS%US, CS%HI) - ! call create_dyn_horgrid(dG, CS%Grid%HI) - ! call create_dyn_horgrid(dG_in, CS%Grid_in%HI) - ! call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) - ! ! Set up the bottom depth, G%D either analytically or from file - ! call set_grid_metrics(dG_in,param_file,CS%US) - ! call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file) - ! call rescale_dyn_horgrid_bathymetry(dG_in, CS%US%Z_to_m) - ! call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) - ! call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) - ! else - !CS%Grid=>CS%Grid_in - dG => NULL() - !CS%Grid%HI=>CS%Grid_in%HI - call create_dyn_horgrid(dG, CS%Grid%HI) - call clone_MOM_domain(CS%Grid%Domain,dG%Domain) - call set_grid_metrics(dG,param_file,CS%US) - ! Set up the bottom depth, dG%bathyT, either analytically or from file - call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file, CS%US) - call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) - call destroy_dyn_horgrid(dG) -! endif - G => CS%Grid ; CS%Grid_in => CS%Grid + if (num_PEs() /= 1) call MOM_error(FATAL, "Index rotation is only supported on one PE.") + + call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & + "Number of counterclockwise quarter-turn index rotations.", & + default=1, debuggingParam=.true.) + ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. + ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. + call create_dyn_horgrid(dG_in, CS%Grid_in%HI) + call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) + call set_grid_metrics(dG_in, param_file, CS%US) + ! Set up the bottom depth, dG_in%bathyT, either analytically or from file + call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file, CS%US) + call copy_dyngrid_to_MOM_grid(dG_in, CS%Grid_in, CS%US) + + ! Now set up the rotated ice-shelf grid. + allocate(CS%Grid) + call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain, turns=CS%turns) + call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) + call MOM_grid_init(CS%Grid, param_file, CS%US, CS%Grid%HI) + call create_dyn_horgrid(dG, CS%Grid%HI) + call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) + + call destroy_dyn_horgrid(dG_in) + call destroy_dyn_horgrid(dG) + else + CS%Grid => CS%Grid_in + dG => NULL() + call create_dyn_horgrid(dG, CS%Grid%HI) + call clone_MOM_domain(CS%Grid%Domain, dG%Domain) + call set_grid_metrics(dG, param_file, CS%US) + ! Set up the bottom depth, dG%bathyT, either analytically or from file + call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file, CS%US) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) + call destroy_dyn_horgrid(dG) + endif + G => CS%Grid allocate(CS%diag) call MOM_IS_diag_mediator_init(G, CS%US, param_file, CS%diag, component='MOM_IceShelf') @@ -1584,14 +1694,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, "buoyancy iteration.", units="nondim", default=1.0e-4) if (PRESENT(sfc_state_in)) then - allocate(sfc_state) ! assuming frazil is enabled in ocean. This could break some configurations? call allocate_surface_state(sfc_state_in, CS%Grid_in, use_temperature=.true., & do_integrals=.true., omit_frazil=.false., use_iceshelves=.true.) if (CS%rotate_index) then - call rotate_surface_state(sfc_state_in, sfc_state,CS%Grid, CS%turns) + allocate(sfc_state) + call rotate_surface_state(sfc_state_in, sfc_state, CS%Grid, CS%turns) else - sfc_state=>sfc_state_in + sfc_state => sfc_state_in endif endif @@ -1671,6 +1781,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, units="m s-1", default=-1.0, scale=US%m_to_Z*US%T_to_s, & do_not_log=CS%ustar_shelf_from_vel) + if (present(calve_ice_shelf_bergs)) CS%calve_ice_shelf_bergs=calve_ice_shelf_bergs + ! Allocate and initialize state variables to default values call ice_shelf_state_init(CS%ISS, CS%grid) ISS => CS%ISS @@ -1726,6 +1838,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, "Ice shelf area in cell", "m2", conversion=US%L_to_m**2) call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & "ice sheet/shelf thickness", "m", conversion=US%Z_to_m) + + if (CS%calve_ice_shelf_bergs) then + call register_restart_field(ISS%calving, "shelf_calving", .true., CS%restart_CSp, & + "Calving flux from ice shelf into icebergs", "kg m-2", conversion=US%RZ_to_kg_m2) + call register_restart_field(ISS%calving_hflx, "shelf_calving_hflx", .true., CS%restart_CSp, & + "Calving heat flux from ice shelf into icebergs", "W m-2", conversion=US%QRZ_T_to_W_m2) + endif + 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", & @@ -1768,8 +1888,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, endif enddo ; enddo if (CS%debug) then - call hchksum(ISS%mass_shelf, "IS init: mass_shelf", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) - call hchksum(ISS%area_shelf_h, "IS init: area_shelf", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) + call hchksum(ISS%mass_shelf, "IS init: mass_shelf", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) + call hchksum(ISS%area_shelf_h, "IS init: area_shelf", G%HI, haloshift=0, unscale=US%L_to_m*US%L_to_m) call hchksum(ISS%hmask, "IS init: hmask", G%HI, haloshift=0) endif @@ -1804,7 +1924,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, enddo ; enddo if (CS%debug) then - call hchksum(ISS%area_shelf_h, "IS init: area_shelf_h", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) + call hchksum(ISS%area_shelf_h, "IS init: area_shelf_h", G%HI, haloshift=0, unscale=US%L_to_m*US%L_to_m) endif CS%Time = Time @@ -1814,7 +1934,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, endif if (CS%shelf_mass_is_dynamic) & - call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, & + call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, CS%Cp_ice, & Time_init, directory, solo_ice_sheet_in) call fix_restart_unit_scaling(US, unscaled=.true.) @@ -1827,8 +1947,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1))) then + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_waypoint("About to call save_restart (MOM_ice_shelf)") call save_restart(dirs%output_directory, CS%Time, CS%Grid_in, CS%restart_CSp, & filename=IC_file, write_ic=.true.) + if (showCallTree) call callTree_waypoint("Done with call to save_restart (MOM_ice_shelf)") endif CS%id_area_shelf_h = register_diag_field('ice_shelf_model', 'area_shelf_h', CS%diag%axesT1, CS%Time, & @@ -1879,6 +2002,153 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, 'ice shelf surface mass flux deposition from atmosphere', & 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) endif + + !scalars (area integrated over all ice sheets) + CS%id_vaf = register_scalar_field('ice_shelf_model', 'int_vaf', CS%diag%axesT1, CS%Time, & + 'Area integrated ice sheet volume above floatation', 'm3') + CS%id_adott = register_scalar_field('ice_shelf_model', 'int_a', CS%diag%axesT1, CS%Time, & + 'Area integrated change in ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_g_adott = register_scalar_field('ice_shelf_model', 'int_a_ground', CS%diag%axesT1, CS%Time, & + 'Area integrated change in grounded ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_f_adott = register_scalar_field('ice_shelf_model', 'int_a_float', CS%diag%axesT1, CS%Time, & + 'Area integrated change in floating ice-shelf thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_bdott = register_scalar_field('ice_shelf_model', 'int_b', CS%diag%axesT1, CS%Time, & + 'Area integrated change in floating ice-shelf thickness '//& + 'due to basal accum+melt during a DT_THERM time step', 'm3') + CS%id_bdott_melt = register_scalar_field('ice_shelf_model', 'int_b_melt', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt over ice shelves during a DT_THERM time step', 'm3') + CS%id_bdott_accum = register_scalar_field('ice_shelf_model', 'int_b_accum', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation over ice shelves during a DT_THERM a time step', 'm3') + CS%id_t_area = register_scalar_field('ice_shelf_model', 'tot_area', CS%diag%axesT1, CS%Time, & + 'Total ice-sheet area', 'm2') + CS%id_f_area = register_scalar_field('ice_shelf_model', 'tot_area_float', CS%diag%axesT1, CS%Time, & + 'Total area of floating ice shelves', 'm2') + CS%id_g_area = register_scalar_field('ice_shelf_model', 'tot_area_ground', CS%diag%axesT1, CS%Time, & + 'Total area of grounded ice sheets', 'm2') + !scalars (area integrated rates over all ice sheets) + CS%id_dvafdt = register_scalar_field('ice_shelf_model', 'int_vafdot', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in ice-sheet volume above floatation', 'm3 s-1') + CS%id_adot = register_scalar_field('ice_shelf_model', 'int_adot', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_g_adot = register_scalar_field('ice_shelf_model', 'int_adot_ground', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in grounded ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_f_adot = register_scalar_field('ice_shelf_model', 'int_adot_float', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in floating ice-shelf thickness due to surface accum+melt', 'm3 s-1') + CS%id_bdot = register_scalar_field('ice_shelf_model', 'int_bdot', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in ice-shelf thickness due to basal accum+melt', 'm3 s-1') + CS%id_bdot_melt = register_scalar_field('ice_shelf_model', 'int_bdot_melt', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt rate over ice shelves', 'm3 s-1') + CS%id_bdot_accum = register_scalar_field('ice_shelf_model', 'int_bdot_accum', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation rate over ice shelves', 'm3 s-1') + + !scalars (area integrated over the Antarctic ice sheet) + CS%id_Ant_vaf = register_scalar_field('ice_shelf_model', 'int_vaf_A', CS%diag%axesT1, CS%Time, & + 'Area integrated Antarctic ice sheet volume above floatation', 'm3') + CS%id_Ant_adott = register_scalar_field('ice_shelf_model', 'int_a_A', CS%diag%axesT1, CS%Time, & + 'Area integrated (Antarctic ice sheet) change in ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Ant_g_adott = register_scalar_field('ice_shelf_model', 'int_a_ground_A', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Antarctic grounded ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Ant_f_adott = register_scalar_field('ice_shelf_model', 'int_a_float_A', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Antarctic floating ice-shelf thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Ant_bdott = register_scalar_field('ice_shelf_model', 'int_b_A', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Antarctic floating ice-shelf thickness '//& + 'due to basal accum+melt during a DT_THERM time step', 'm3') + CS%id_Ant_bdott_melt = register_scalar_field('ice_shelf_model', 'int_b_melt_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt over Antarctic ice shelves during a DT_THERM time step', 'm3') + CS%id_Ant_bdott_accum = register_scalar_field('ice_shelf_model', 'int_b_accum_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation over Antarctic ice shelves during a DT_THERM a time step', 'm3') + CS%id_Ant_t_area = register_scalar_field('ice_shelf_model', 'tot_area_A', CS%diag%axesT1, CS%Time, & + 'Total area of Antarctic ice sheet', 'm2') + CS%id_Ant_f_area = register_scalar_field('ice_shelf_model', 'tot_area_float_A', CS%diag%axesT1, CS%Time, & + 'Total area of Antarctic floating ice shelves', 'm2') + CS%id_Ant_g_area = register_scalar_field('ice_shelf_model', 'tot_area_ground_A', CS%diag%axesT1, CS%Time, & + 'Total area of Antarctic grounded ice sheet', 'm2') + !scalars (area integrated rates over the Antarctic ice sheet) + CS%id_Ant_dvafdt = register_scalar_field('ice_shelf_model', 'int_vafdot_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic ice-sheet volume above floatation', 'm3 s-1') + CS%id_Ant_adot = register_scalar_field('ice_shelf_model', 'int_adot_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_Ant_g_adot = register_scalar_field('ice_shelf_model', 'int_adot_ground_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic grounded ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_Ant_f_adot = register_scalar_field('ice_shelf_model', 'int_adot_float_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic floating ice-shelf thickness due to surface accum+melt', 'm3 s-1') + CS%id_Ant_bdot = register_scalar_field('ice_shelf_model', 'int_bdot_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic ice-shelf thickness due to basal accum+melt', 'm3 s-1') + CS%id_Ant_bdot_melt = register_scalar_field('ice_shelf_model', 'int_bdot_melt_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt rate over Antarctic ice shelves', 'm3 s-1') + CS%id_Ant_bdot_accum = register_scalar_field('ice_shelf_model', 'int_bdot_accum_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation rate over Antarctic ice shelves', 'm3 s-1') + + !scalars (area integrated over the Greenland ice sheet) + CS%id_Gr_vaf = register_scalar_field('ice_shelf_model', 'int_vaf_G', CS%diag%axesT1, CS%Time, & + 'Area integrated Greenland ice sheet volume above floatation', 'm3') + CS%id_Gr_adott = register_scalar_field('ice_shelf_model', 'int_a_G', CS%diag%axesT1, CS%Time, & + 'Area integrated (Greenland ice sheet) change in ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Gr_g_adott = register_scalar_field('ice_shelf_model', 'int_a_ground_G', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Greenland grounded ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Gr_f_adott = register_scalar_field('ice_shelf_model', 'int_a_float_G', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Greenland floating ice-shelf thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Gr_bdott = register_scalar_field('ice_shelf_model', 'int_b_G', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Greenland floating ice-shelf thickness '//& + 'due to basal accum+melt during a DT_THERM time step', 'm3') + CS%id_Gr_bdott_melt = register_scalar_field('ice_shelf_model', 'int_b_melt_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt over Greenland ice shelves during a DT_THERM time step', 'm3') + CS%id_Gr_bdott_accum = register_scalar_field('ice_shelf_model', 'int_b_accum_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation over Greenland ice shelves during a DT_THERM a time step', 'm3') + CS%id_Gr_t_area = register_scalar_field('ice_shelf_model', 'tot_area_G', CS%diag%axesT1, CS%Time, & + 'Total area of Greenland ice sheet', 'm2') + CS%id_Gr_f_area = register_scalar_field('ice_shelf_model', 'tot_area_float_G', CS%diag%axesT1, CS%Time, & + 'Total area of Greenland floating ice shelves', 'm2') + CS%id_Gr_g_area = register_scalar_field('ice_shelf_model', 'tot_area_ground_G', CS%diag%axesT1, CS%Time, & + 'Total area of Greenland grounded ice sheet', 'm2') + !scalars (area integrated rates over the Greenland ice sheet) + CS%id_Gr_dvafdt = register_scalar_field('ice_shelf_model', 'int_vafdot_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland ice-sheet volume above floatation', 'm3 s-1') + CS%id_Gr_adot = register_scalar_field('ice_shelf_model', 'int_adot_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_Gr_g_adot = register_scalar_field('ice_shelf_model', 'int_adot_ground_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland grounded ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_Gr_f_adot = register_scalar_field('ice_shelf_model', 'int_adot_float_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland floating ice-shelf thickness due to surface accum+melt', 'm3 s-1') + CS%id_Gr_bdot = register_scalar_field('ice_shelf_model', 'int_bdot_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland ice-shelf thickness due to basal accum+melt', 'm3 s-1') + CS%id_Gr_bdot_melt = register_scalar_field('ice_shelf_model', 'int_bdot_melt_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt rate over Greenland ice shelves', 'm3 s-1') + CS%id_Gr_bdot_accum = register_scalar_field('ice_shelf_model', 'int_bdot_accum_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation rate over Greenland ice shelves', 'm3 s-1') + + !Flags to calculate diagnostics related to surface/basal mass balance + if (CS%id_adott>0 .or. CS%id_g_adott>0 .or. CS%id_f_adott>0 .or. & + CS%id_adot >0 .or. CS%id_g_adot >0 .or. CS%id_f_adot >0 .or. & + CS%id_Ant_adott>0 .or. CS%id_Ant_g_adott>0 .or. CS%id_Ant_f_adott>0 .or. & + CS%id_Ant_adot >0 .or. CS%id_Ant_g_adot >0 .or. CS%id_Ant_f_adot >0 .or. & + CS%id_Gr_adott>0 .or. CS%id_Gr_g_adott>0 .or. CS%id_Gr_f_adott>0 .or. & + CS%id_Gr_adot >0 .or. CS%id_Gr_g_adot >0 .or. CS%id_Gr_f_adot >0) then + CS%smb_diag=.true. + else + CS%smb_diag=.false. + endif + + if (CS%id_bdott>0 .or. CS%id_bdott_melt>0 .or. CS%id_bdott_accum>0 .or. & + CS%id_bdot >0 .or. CS%id_bdot_melt >0 .or. CS%id_bdot_accum >0 .or. & + CS%id_Ant_bdott>0 .or. CS%id_Ant_bdott_melt>0 .or. CS%id_Ant_bdott_accum>0 .or. & + CS%id_Ant_bdot >0 .or. CS%id_Ant_bdot_melt >0 .or. CS%id_Ant_bdot_accum >0 .or. & + CS%id_Gr_bdott>0 .or. CS%id_Gr_bdott_melt>0 .or. CS%id_Gr_bdott_accum>0 .or. & + CS%id_Gr_bdot >0 .or. CS%id_Gr_bdot_melt >0 .or. CS%id_Gr_bdot_accum >0) then + CS%bmb_diag=.true. + else + CS%bmb_diag=.false. + endif + call MOM_IS_diag_mediator_close_registration(CS%diag) if (present(fluxes_in)) call initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) @@ -1913,14 +2183,14 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) else call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & - press=.true., shelf_sfc_accumulation = CS%active_shelf_dynamics, tau_mag=.true.) + press=.true., shelf_sfc_accumulation=CS%active_shelf_dynamics, tau_mag=.true.) endif if (CS%rotate_index) then allocate(fluxes) - call allocate_forcing_type(fluxes_in, CS%Grid, fluxes) + call allocate_forcing_type(fluxes_in, CS%Grid, fluxes, turns=CS%turns) call rotate_forcing(fluxes_in, fluxes, CS%turns) else - fluxes=>fluxes_in + fluxes => fluxes_in endif do j=jsd,jed ; do i=isd,ied @@ -1929,21 +2199,31 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) if (CS%debug) call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) call add_shelf_pressure(ocn_grid, US, CS, fluxes) - if (CS%rotate_index) & + if (CS%rotate_index) then call rotate_forcing(fluxes, fluxes_in, -CS%turns) + call deallocate_forcing_type(fluxes) + deallocate(fluxes) + endif end subroutine initialize_ice_shelf_fluxes +!> Allocate and initialize the ice-shelf forcing elements of a mechanical forcing type. +!! This forcing type is on the unrotated grid that is used outside of the MOM6 ice shelf code. subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal 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(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces ! Local variables type(mech_forcing), pointer :: forces => NULL() call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating forces.") + + if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + call MOM_error(FATAL,"initialize_ice_shelf_forces: Incompatible ocean and external ice shelf grids.") + call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) if (CS%rotate_index) then allocate(forces) @@ -1953,10 +2233,13 @@ subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) forces=>forces_in endif - call add_shelf_forces(ocn_grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) + call add_shelf_forces(CS%grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet, & + external_call=.false.) - if (CS%rotate_index) & + if (CS%rotate_index) then call rotate_mech_forcing(forces, -CS%turns, forces_in) + call deallocate_mech_forcing(forces) + endif end subroutine initialize_ice_shelf_forces @@ -2080,7 +2363,7 @@ subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time ISS%hmask(i,j) = 0.0 ISS%area_shelf_h(i,j) = 0.0 endif - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * CS%density_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice endif enddo ; enddo @@ -2241,6 +2524,11 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in logical :: coupled_GL ! If true the grounding line position is determined based on ! coupled ice-ocean dynamics. integer :: is, ie, js, je, i, j + real :: vaf0, vaf0_A, vaf0_G !The previous volumes above floatation + !for all ice sheets, Antarctica only, or Greenland only [m3] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & + dh_adott_sum, & ! Surface melt/accumulation over a full time step, used for diagnostics [Z ~> m] + dh_adott ! Surface melt/accumulation over a partial time step, used for diagnostics [Z ~> m] G => CS%grid US => CS%US @@ -2262,6 +2550,15 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + dh_adott(:,:)=0.0 + + if (CS%smb_diag) dh_adott_sum(:,:) = 0.0 + + !calculate previous volumes above floatation + if (CS%id_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0) !all ice sheet + if (CS%id_Ant_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_A, hemisphere=0) !Antarctica only + if (CS%id_Gr_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_G, hemisphere=1) !Greenland only + do while (remaining_time > 0.0) nsteps = nsteps+1 @@ -2275,7 +2572,10 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) endif + if (CS%smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_precip(CS, ISS, G, US, fluxes_in, time_step, Time) + if (CS%smb_diag) dh_adott_sum(is:ie,js:je) = dh_adott_sum(is:ie,js:je) + & + (ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je)) remaining_time = remaining_time - time_step @@ -2284,25 +2584,245 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in update_ice_vel = ((time_step > min_time_step) .or. (remaining_time > 0.0)) coupled_GL = .false. - call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, must_update_vel=update_ice_vel) + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, CS%calve_ice_shelf_bergs, & + must_update_vel=update_ice_vel) enddo - call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & - time_step=real_to_time(US%T_to_s*time_step) ) + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, ISS%area_shelf_h, Time, & + time_step=time_interval) do j=js,je ; do i=is,ie ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j)) * Ifull_time_step enddo; enddo call enable_averages(full_time_step, Time, CS%diag) - if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) - if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) - if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) - if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) + if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h ,ISS%area_shelf_h,CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf ,ISS%h_shelf ,CS%diag) + if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf ,ISS%dhdt_shelf ,CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask ,ISS%hmask ,CS%diag) + call process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Ifull_time_step, dh_adott, dh_adott*0.0) call disable_averaging(CS%diag) + call IS_dynamics_post_data(full_time_step, Time, CS%dCS, ISS, G) end subroutine solo_step_ice_shelf +!> Post_data calls for ice-sheet scalars +subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh_adott, dh_bdott) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + real :: vaf0 !< The previous volumes above floatation for all ice sheets [m3] + real :: vaf0_A !< The previous volumes above floatation for the Antarctic ice sheet [m3] + real :: vaf0_G !< The previous volumes above floatation for the Greenland ice sheet [m3] + real :: Itime_step !< Inverse of the time step [T-1 ~> s-1] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: dh_adott !< Surface (plus basal if solo shelf mode) + !! melt/accumulation over a time step [Z ~> m] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: dh_bdott !< Surface (plus basal if solo shelf mode) + !! melt/accumulation over a time step [Z ~> m] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: tmp ! Temporary field used when calculating diagnostics [various] + real :: vaf ! The current ice-sheet volume above floatation [m3] + real :: val ! Temporary value when calculating scalar diagnostics [various] + type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the ocean's grid structure + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing various unit conversion factors + type(ice_shelf_state), pointer :: ISS => NULL() ! A structure with elements that describe the ice-shelf state + integer :: is, ie, js, je, i, j + + G => CS%grid + US => CS%US + ISS => CS%ISS + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + !---ALL ICE SHEET---! + if (CS%id_vaf > 0 .or. CS%id_dvafdt > 0) & !calculate current volume above floatation (vaf) + call volume_above_floatation(CS%dCS, G, ISS, vaf) + if (CS%id_vaf > 0) call post_scalar_data(CS%id_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_dvafdt > 0) call post_scalar_data(CS%id_dvafdt,(vaf-vaf0)*Itime_step,CS%diag) !d(vaf)/dt + if (CS%id_adott > 0 .or. CS%id_adot > 0) then !surface accumulation - surface melt + call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val) + if (CS%id_adott > 0) call post_scalar_data(CS%id_adott,val ,CS%diag) + if (CS%id_adot > 0) call post_scalar_data(CS%id_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_g_adott > 0 .or. CS%id_g_adot > 0) then !grounded only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_g_adott > 0) call post_scalar_data(CS%id_g_adott,val ,CS%diag) + if (CS%id_g_adot > 0) call post_scalar_data(CS%id_g_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_f_adott > 0 .or. CS%id_f_adot > 0) then !floating only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + do j=js,je ; do i=is,ie + tmp(i,j) = dh_adott(i,j) - tmp(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_f_adott > 0) call post_scalar_data(CS%id_f_adott,val ,CS%diag) + if (CS%id_f_adot > 0) call post_scalar_data(CS%id_f_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_bdott > 0 .or. CS%id_bdot > 0) then !bottom accumulation - bottom melt + call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val) + if (CS%id_bdott > 0) call post_scalar_data(CS%id_bdott,val ,CS%diag) + if (CS%id_bdot > 0) call post_scalar_data(CS%id_bdot ,val*Itime_step,CS%diag) + endif + if (CS%id_bdott_melt > 0 .or. CS%id_bdot_melt > 0) then !bottom melt + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_bdott_melt > 0) call post_scalar_data(CS%id_bdott_melt,val ,CS%diag) + if (CS%id_bdot_melt > 0) call post_scalar_data(CS%id_bdot_melt ,val*Itime_step,CS%diag) + endif + if (CS%id_bdott_accum > 0 .or. CS%id_bdot_accum > 0) then !bottom accumulation + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_bdott_accum > 0) call post_scalar_data(CS%id_bdott_accum,val ,CS%diag) + if (CS%id_bdot_accum > 0) call post_scalar_data(CS%id_bdot_accum ,val*Itime_step,CS%diag) + endif + if (CS%id_t_area > 0) then !ice sheet area + tmp(:,:) = 1.0; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) + call post_scalar_data(CS%id_t_area,val,CS%diag) + endif + if (CS%id_g_area > 0 .or. CS%id_f_area > 0) then + tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) + if (CS%id_g_area > 0) then !grounded only ice sheet area + call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) + call post_scalar_data(CS%id_g_area,val,CS%diag) + endif + if (CS%id_f_area > 0) then !floating only ice sheet area (ice shelf area) + call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val) + call post_scalar_data(CS%id_f_area,val,CS%diag) + endif + endif + + !---ANTARCTICA ONLY---! + if (CS%id_Ant_vaf > 0 .or. CS%id_Ant_dvafdt > 0) & !calculate current volume above floatation (vaf) + call volume_above_floatation(CS%dCS, G, ISS, vaf, hemisphere=0) + if (CS%id_Ant_vaf > 0) call post_scalar_data(CS%id_Ant_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_Ant_dvafdt > 0) call post_scalar_data(CS%id_Ant_dvafdt,(vaf-vaf0_A)*Itime_step,CS%diag) !d(vaf)/dt + if (CS%id_Ant_adott > 0 .or. CS%id_Ant_adot > 0) then !surface accumulation - surface melt + call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_adott > 0) call post_scalar_data(CS%id_Ant_adott,val ,CS%diag) + if (CS%id_Ant_adot > 0) call post_scalar_data(CS%id_Ant_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_g_adott > 0 .or. CS%id_Ant_g_adot > 0) then !grounded only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_g_adott > 0) call post_scalar_data(CS%id_Ant_g_adott,val ,CS%diag) + if (CS%id_Ant_g_adot > 0) call post_scalar_data(CS%id_Ant_g_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_f_adott > 0 .or. CS%id_Ant_f_adot > 0) then !floating only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + do j=js,je ; do i=is,ie + tmp(i,j) = dh_adott(i,j) - tmp(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_f_adott > 0) call post_scalar_data(CS%id_Ant_f_adott,val ,CS%diag) + if (CS%id_Ant_f_adot > 0) call post_scalar_data(CS%id_Ant_f_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_bdott > 0 .or. CS%id_Ant_bdot > 0) then !bottom accumulation - bottom melt + call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_bdott > 0) call post_scalar_data(CS%id_Ant_bdott,val ,CS%diag) + if (CS%id_Ant_bdot > 0) call post_scalar_data(CS%id_Ant_bdot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_bdott_melt > 0 .or. CS%id_Ant_bdot_melt > 0) then !bottom melt + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_bdott_melt > 0) call post_scalar_data(CS%id_Ant_bdott_melt,val ,CS%diag) + if (CS%id_Ant_bdot_melt > 0) call post_scalar_data(CS%id_Ant_bdot_melt ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_bdott_accum > 0 .or. CS%id_Ant_bdot_accum > 0) then !bottom accumulation + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_bdott_accum > 0) call post_scalar_data(CS%id_Ant_bdott_accum,val ,CS%diag) + if (CS%id_Ant_bdot_accum > 0) call post_scalar_data(CS%id_Ant_bdot_accum ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_t_area > 0) then !ice sheet area + tmp(:,:) = 1.0; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=0) + call post_scalar_data(CS%id_Ant_t_area,val,CS%diag) + endif + if (CS%id_Ant_g_area > 0 .or. CS%id_Ant_f_area > 0) then + tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) + if (CS%id_Ant_g_area > 0) then !grounded only ice sheet area + call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=0) + call post_scalar_data(CS%id_Ant_g_area,val,CS%diag) + endif + if (CS%id_Ant_f_area > 0) then !floating only ice sheet area (ice shelf area) + call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val, hemisphere=0) + call post_scalar_data(CS%id_Ant_f_area,val,CS%diag) + endif + endif + + !---GREENLAND ONLY---! + if (CS%id_Gr_vaf > 0 .or. CS%id_Gr_dvafdt > 0) & !calculate current volume above floatation (vaf) + call volume_above_floatation(CS%dCS, G, ISS, vaf, hemisphere=1) + if (CS%id_Gr_vaf > 0) call post_scalar_data(CS%id_Gr_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_Gr_dvafdt > 0) call post_scalar_data(CS%id_Gr_dvafdt,(vaf-vaf0_A)*Itime_step,CS%diag) !d(vaf)/dt + if (CS%id_Gr_adott > 0 .or. CS%id_Gr_adot > 0) then !surface accumulation - surface melt + call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_adott > 0) call post_scalar_data(CS%id_Gr_adott,val ,CS%diag) + if (CS%id_Gr_adot > 0) call post_scalar_data(CS%id_Gr_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_g_adott > 0 .or. CS%id_Gr_g_adot > 0) then !grounded only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_g_adott > 0) call post_scalar_data(CS%id_Gr_g_adott,val ,CS%diag) + if (CS%id_Gr_g_adot > 0) call post_scalar_data(CS%id_Gr_g_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_f_adott > 0 .or. CS%id_Gr_f_adot > 0) then !floating only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + do j=js,je ; do i=is,ie + tmp(i,j) = dh_adott(i,j) - tmp(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_f_adott > 0) call post_scalar_data(CS%id_Gr_f_adott,val ,CS%diag) + if (CS%id_Gr_f_adot > 0) call post_scalar_data(CS%id_Gr_f_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_bdott > 0 .or. CS%id_Gr_bdot > 0) then !bottom accumulation - bottom melt + call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_bdott > 0) call post_scalar_data(CS%id_Gr_bdott,val ,CS%diag) + if (CS%id_Gr_bdot > 0) call post_scalar_data(CS%id_Gr_bdot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_bdott_melt > 0 .or. CS%id_Gr_bdot_melt > 0) then !bottom melt + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_bdott_melt > 0) call post_scalar_data(CS%id_Gr_bdott_melt,val ,CS%diag) + if (CS%id_Gr_bdot_melt > 0) call post_scalar_data(CS%id_Gr_bdot_melt ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_bdott_accum > 0 .or. CS%id_Gr_bdot_accum > 0) then !bottom accumulation + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_bdott_accum > 0) call post_scalar_data(CS%id_Gr_bdott_accum,val ,CS%diag) + if (CS%id_Gr_bdot_accum > 0) call post_scalar_data(CS%id_Gr_bdot_accum ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_t_area > 0) then !ice sheet area + tmp(:,:) = 1.0; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=1) + call post_scalar_data(CS%id_Gr_t_area,val,CS%diag) + endif + if (CS%id_Gr_g_area > 0 .or. CS%id_Gr_f_area > 0) then + tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) + if (CS%id_Gr_g_area > 0) then !grounded only ice sheet area + call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=1) + call post_scalar_data(CS%id_Gr_g_area,val,CS%diag) + endif + if (CS%id_Gr_f_area > 0) then !floating only ice sheet area (ice shelf area) + call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val, hemisphere=1) + call post_scalar_data(CS%id_Gr_f_area,val,CS%diag) + endif + endif +end subroutine process_and_post_scalar_data + !> \namespace mom_ice_shelf !! !! \section section_ICE_SHELF diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index 42fa63fd95..5ecfb9e788 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -27,6 +27,7 @@ module MOM_IS_diag_mediator public MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end, set_IS_diag_mediator_grid public MOM_IS_diag_mediator_close_registration, get_diag_time_end public MOM_diag_axis_init, register_static_field_infra +public register_MOM_IS_scalar_field, post_IS_data_0d !> 2D/3D axes type to contain 1D axes handles and pointers to masks type, public :: axesType @@ -344,6 +345,36 @@ subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask) end subroutine post_IS_data +!> Make a real ice shelf scalar diagnostic available for averaging or output +subroutine post_IS_data_0d(diag_field_id, field, diag_cs, is_static) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field !< real value being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + ! Local variables + real :: locfield ! The field being offered in arbitrary unscaled units [a] + logical :: used, is_stat + type(diag_type), pointer :: diag => null() + + is_stat = .false. ; if (present(is_static)) is_stat = is_static + + call assert(diag_field_id < diag_cs%next_free_diag_id, & + 'post_data_0d: Unregistered diagnostic id') + diag => diag_cs%diags(diag_field_id) + + locfield = field + if (diag%conversion_factor /= 0.) & + locfield = locfield * diag%conversion_factor + + if (is_stat) then + used = send_data_infra(diag%fms_diag_id, locfield) + elseif (diag_cs%ave_enabled) then + used = send_data_infra(diag%fms_diag_id, locfield, diag_cs%time_end) + endif +end subroutine post_IS_data_0d + !> Enable the accumulation of time averages over the specified time interval. subroutine enable_averaging(time_int_in, time_end_in, diag_cs) @@ -429,22 +460,25 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with !! post_IS_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) character(len=*), optional, intent(out):: err_msg !< String into which an error message might be - !! placed (not used in MOM?) + !! placed (not used in MOM?) character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not - !! be interpolated as a scalar - integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?) - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file - + !! be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?) + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] ! Local variables character(len=240) :: mesg - real :: MOM_missing_value + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] integer :: primary_id, fms_id type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used ! to regulate diagnostic output @@ -513,6 +547,71 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & end function register_MOM_IS_diag_field +!> Returns the "MOM_IS_diag_mediator" handle for a group of diagnostics derived from one scalar. +function register_MOM_IS_scalar_field(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, standard_name, & + do_not_log, err_msg, conversion) result (register_scalar_field) + integer :: register_scalar_field !< The returned diagnostic handle + character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axesType), intent(in) :: axes !< The axis group for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + + ! Local variables + character(len=240) :: mesg + real :: MOM_missing_value + integer :: primary_id, fms_id + type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used + ! to regulate diagnostic output + type(diag_type), pointer :: diag => NULL() + + MOM_missing_value = axes%diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + diag_cs => axes%diag_cs + primary_id = -1 + + fms_id = register_diag_field_infra(module_name, field_name, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg) + + if (fms_id > 0) then + primary_id = get_new_diag_id(diag_cs) + diag => diag_cs%diags(primary_id) + diag%fms_diag_id = fms_id + if (len(field_name) > len(diag%name)) then + diag%name = field_name(1:len(diag%name)) + else ; diag%name = field_name ; endif + + if (present(conversion)) diag%conversion_factor = conversion + endif + + if (is_root_pe() .and. diag_CS%doc_unit > 0) then + if (primary_id > 0) then + mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Used]' + else + mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]' + endif + write(diag_CS%doc_unit, '(a)') trim(mesg) + if (present(long_name)) call describe_option("long_name", long_name, diag_CS) + if (present(units)) call describe_option("units", units, diag_CS) + if (present(standard_name)) & + call describe_option("standard_name", standard_name, diag_CS) + endif + + register_scalar_field = primary_id + +end function register_MOM_IS_scalar_field + !> Registers a static diagnostic, returning an integer handle function register_MOM_IS_static_field(module_name, field_name, axes, & long_name, units, missing_value, range, mask_variant, standard_name, & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index ec49081baf..9c7dda22de 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -34,9 +34,10 @@ module MOM_ice_shelf_dynamics #include -public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf +public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf, IS_dynamics_post_data public ice_time_step_CFL, ice_shelf_dyn_end, change_in_draft, write_ice_shelf_energy -public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask +public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask, volume_above_floatation +public masked_var_grounded ! 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 @@ -49,10 +50,14 @@ module MOM_ice_shelf_dynamics !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet !! on q-points (B grid) [L T-1 ~> m s-1] - real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the driving stress of the ice shelf/sheet + real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the zonal driving stress of the ice shelf/sheet !! on q-points (C grid) [R L2 T-2 ~> Pa] - real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional stress of the ice shelf/sheet + real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional driving stress of the ice shelf/sheet !! on q-points (C grid) [R L2 T-2 ~> Pa] + real, pointer, dimension(:,:) :: sx_shelf => NULL() !< the zonal surface slope of the ice shelf/sheet + !! on q-points (B grid) [nondim] + real, pointer, dimension(:,:) :: sy_shelf => NULL() !< the meridional surface slope of the ice shelf/sheet + !! on q-points (B grid) [nondim] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, !! not vertices. Will represent boundary conditions on computational boundary @@ -84,9 +89,9 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: t_shelf => NULL() !< Vertically integrated temperature in the ice shelf/stream, !! on corner-points (B grid) [C ~> 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 (Pa s), - !! in [R L2 T-1 ~> kg m-1 s-1]. - !! at either 1 (cell-centered) or 4 quadrature points per cell + real, pointer, dimension(:,:,:) :: ice_visc => NULL() !< Area and depth-integrated Glen's law ice viscosity + !! (Pa m3 s) in [R L4 Z T-1 ~> kg m2 s-1]. + !! at either 1 (cell-centered) or 4 quadrature points per cell real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, !! often in [Pa-3 s-1] if n_Glen is 3. real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries @@ -106,7 +111,7 @@ module MOM_ice_shelf_dynamics !! of "linearized" basal stress (Pa) [R L3 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 s-1)^(n_basal_fric) + !! units= Pa (s m-1)^(n_basal_fric) real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av [Z ~> m]. 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]. @@ -133,8 +138,11 @@ module MOM_ice_shelf_dynamics real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. + real :: Cp_ice !< The heat capacity of fresh ice [Q C-1 ~> J kg-1 degC-1]. logical :: advect_shelf !< If true (default), advect ice shelf and evolve thickness + logical :: reentrant_x !< If true, the domain is zonally reentrant + logical :: reentrant_y !< If true, the domain is meridionally reentrant logical :: alternate_first_direction_IS !< If true, alternate whether the x- or y-direction !! updates occur first in directionally split parts of the calculation. integer :: first_direction_IS !< An integer that indicates which direction is @@ -160,6 +168,11 @@ 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) [nondim] + real :: min_h_shelf !< The minimum ice thickness used during ice dynamics [L ~> m]. + real :: min_basal_traction !< The minimum basal traction for grounded ice (Pa m-1 s) [R L T-1 ~> kg m-2 s-1] + real :: max_surface_slope !< The maximum allowed ice-sheet surface slope (to ignore, set to zero) [nondim] + real :: min_ice_visc !< The minimum allowed Glen's law ice viscosity (Pa s), in [R L2 T-1 ~> kg m-1 s-1]. + real :: n_glen !< Nonlinearity exponent in Glen's Law [nondim] real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [T-1 ~> s-1]. real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) [nondim] @@ -214,10 +227,17 @@ module MOM_ice_shelf_dynamics logical :: module_is_initialized = .false. !< True if this module has been initialized. !>@{ Diagnostic handles - integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & - id_taudx_shelf = -1, id_taudy_shelf = -1, id_bed_elev = -1, & + integer :: id_u_shelf = -1, id_v_shelf = -1, id_shelf_speed, id_t_shelf = -1, & + id_taudx_shelf = -1, id_taudy_shelf = -1, id_taud_shelf = -1, id_bed_elev = -1, & id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, id_float_cond = -1, & - id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1 + id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1, & + id_sx_shelf = -1, id_sy_shelf = -1, id_surf_slope_mag_shelf, & + id_duHdx = -1, id_dvHdy = -1, id_fluxdiv = -1, & + id_strainrate_xx = -1, id_strainrate_yy = -1, id_strainrate_xy = -1, & + id_pstrainrate_1 = -1, id_pstrainrate_2, & + id_devstress_xx = -1, id_devstress_yy = -1, id_devstress_xy = -1, & + id_pdevstress_1 = -1, id_pdevstress_2 = -1 + !>@} ! ids for outputting intermediate thickness in advection subroutine (debugging) !>@{ Diagnostic handles for debugging @@ -268,9 +288,9 @@ function quad_area (X, Y) ! | | ! 1 - 2 - p2 = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 ; q2 = (X(3)-X(2))**2 + (Y(3)-Y(2))**2 - a2 = (X(3)-X(4))**2 + (Y(3)-Y(4))**2 ; c2 = (X(1)-X(2))**2 + (Y(1)-Y(2))**2 - b2 = (X(2)-X(4))**2 + (Y(2)-Y(4))**2 ; d2 = (X(3)-X(1))**2 + (Y(3)-Y(1))**2 + p2 = ( ((X(4)-X(1))**2) + ((Y(4)-Y(1))**2) ) ; q2 = ( ((X(3)-X(2))**2) + ((Y(3)-Y(2))**2) ) + a2 = ( ((X(3)-X(4))**2) + ((Y(3)-Y(4))**2) ) ; c2 = ( ((X(1)-X(2))**2) + ((Y(1)-Y(2))**2) ) + b2 = ( ((X(2)-X(4))**2) + ((Y(2)-Y(4))**2) ) ; d2 = ( ((X(3)-X(1))**2) + ((Y(3)-Y(1))**2) ) quad_area = .25 * sqrt(4*P2*Q2-(B2+D2-A2-C2)**2) end function quad_area @@ -339,11 +359,13 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate(CS%ice_visc(isd:ied,jsd:jed,CS%visc_qps), source=0.0) allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L3 T-1 ~> kg s-1] - allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] + allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (s m-1)^n_sliding] allocate(CS%OD_av(isd:ied,jsd:jed), source=0.0) allocate(CS%ground_frac(isd:ied,jsd:jed), source=0.0) allocate(CS%taudx_shelf(IsdB:IedB,JsdB:JedB), source=0.0) allocate(CS%taudy_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%sx_shelf(isd:ied,jsd:jed), source=0.0) + allocate(CS%sy_shelf(isd:ied,jsd:jed), source=0.0) allocate(CS%bed_elev(isd:ied,jsd:jed), source=0.0) allocate(CS%u_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) allocate(CS%v_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) @@ -374,7 +396,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) 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, "C_basal_friction", .true., restart_CS, & - "basal sliding coefficients", "Pa (m s-1)^n_sliding") + "basal sliding coefficients", "Pa (s m-1)^n_sliding") call register_restart_field(CS%AGlen_visc, "AGlen_visc", .true., restart_CS, & "ice-stiffness parameter", "Pa-3 s-1") call register_restart_field(CS%h_bdry_val, "h_bdry_val", .false., restart_CS, & @@ -388,7 +410,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) end subroutine register_ice_shelf_dyn_restarts !> Initializes shelf model data, parameters and diagnostics -subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, & +subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, Cp_ice, & Input_start_time, directory, solo_ice_sheet_in) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time @@ -400,6 +422,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise !! has been started from a restart file. + real, intent(in) :: Cp_ice !< Heat capacity of ice [Q C-1 ~> J kg-1 degC-1] type(time_type), intent(in) :: Input_start_time !< The start time of the simulation. character(len=*), intent(in) :: directory !< The directory where the ice sheet energy file goes. logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether @@ -486,6 +509,19 @@ 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, "MIN_H_SHELF", CS%min_h_shelf, & + "min. ice thickness used during ice dynamics", & + units="m", default=0.,scale=US%m_to_L) + call get_param(param_file, mdl, "MIN_BASAL_TRACTION", CS%min_basal_traction, & + "min. allowed basal traction. Input is in [Pa m-1 yr], but is converted when read in to [Pa m-1 s]", & + units="Pa m-1 yr", default=0., scale=365.0*86400.0*US%Pa_to_RLZ_T2*US%L_T_to_m_s) + call get_param(param_file, mdl, "MAX_SURFACE_SLOPE", CS%max_surface_slope, & + "max. allowed ice-sheet surface slope. To ignore, set to zero.", & + units="none", default=0., scale=US%m_to_Z/US%m_to_L) + call get_param(param_file, mdl, "MIN_ICE_VISC", CS%min_ice_visc, & + "min. allowed Glen's law ice viscosity", & + units="Pa s", default=0., scale=US%Pa_to_RL2_T2*US%s_to_T) + call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & "nonlinearity exponent in Glen's Law", & units="none", default=3.) @@ -522,7 +558,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ units="m", default=1.e-3, scale=US%m_to_Z) call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & "Choose whether nonlin error in vel solve is based on nonlinear "//& - "residual (1), relative change since last iteration (2), or change in norm (3)", default=1) + "residual (1), relative change since last iteration (2), or change in norm (3)", default=3) call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & "Specify whether to advance shelf front (and calve).", & @@ -533,6 +569,12 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "ADVECT_SHELF", CS%advect_shelf, & "If true, advect ice shelf and evolve thickness", & default=.true.) + call get_param(param_file, mdl, "REENTRANT_X", CS%reentrant_x, & + " If true, the domain is zonally reentrant.", & + default=.false.) + call get_param(param_file, mdl, "REENTRANT_Y", CS%reentrant_y, & + " If true, the domain is meridionally reentrant.", & + default=.false.) call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, & "If MODEL, compute ice viscosity internally using 1 or 4 quadrature points,"//& "if OBS read from a file,"//& @@ -552,7 +594,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", CS%min_thickness_simple_calve, & "Min thickness rule for the VERY simple calving law",& units="m", default=0.0, scale=US%m_to_Z) - + CS%Cp_ice = Cp_ice !Heat capacity of ice (J kg-1 K-1), needed for heat flux of any bergs calved from + !the ice shelf and for ice sheet temperature solver !for write_ice_shelf_energy ! Note that the units of CS%Timeunit are the MKS units of [s]. call get_param(param_file, mdl, "TIMEUNIT", CS%Timeunit, & @@ -638,9 +681,22 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Take additional initialization steps, for example of dependent variables. if (active_shelf_dynamics .and. .not.new_sim) then - ! this is unfortunately necessary; if grid is not symmetric the boundary values - ! of u and v are otherwise not set till the end of the first linear solve, and so - ! viscosity is not calculated correctly. + call pass_var(CS%OD_av,G%domain, complete=.false.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%basal_traction, G%domain, complete=.false.) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.false.) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.true.) + call pass_var(CS%ice_visc, G%domain) + + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.true.) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + + ! This is unfortunately necessary (?); if grid is not symmetric the boundary values + ! of u and v are otherwise not set till the end of the first linear solve, and so + ! viscosity is not calculated correctly. ! This has to occur after init_boundary_values or some of the arrays on the ! right hand side have not been set up yet. if (.not. G%symmetric) then @@ -675,20 +731,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif enddo ; enddo endif - - call pass_var(CS%OD_av,G%domain, complete=.false.) - call pass_var(CS%ground_frac, G%domain, complete=.false.) - call pass_var(CS%basal_traction, G%domain, complete=.false.) - call pass_var(CS%AGlen_visc, G%domain, complete=.false.) - call pass_var(CS%bed_elev, G%domain, complete=.false.) - call pass_var(CS%C_basal_friction, G%domain, complete=.false.) - call pass_var(CS%h_bdry_val, G%domain, complete=.true.) - call pass_var(CS%ice_visc, G%domain) - - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.false.) - call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) - call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.true.) - call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) endif if (active_shelf_dynamics) then @@ -748,16 +791,40 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%ground_frac, G%domain, complete=.false.) call pass_var(CS%bed_elev, G%domain, complete=.true.) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 3) then + CS%u_shelf(I,J) = CS%u_bdry_val(I,J) + elseif (CS%umask(I,J) == 0) then + CS%u_shelf(I,J) = 0 + endif + if (CS%vmask(I,J) == 3) then + CS%v_shelf(I,J) = CS%v_bdry_val(I,J) + elseif (CS%vmask(I,J) == 0) then + CS%v_shelf(I,J) = 0 + endif + enddo ; enddo endif + ! Register diagnostics. CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesB1, Time, & 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesB1, Time, & 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) + CS%id_shelf_speed = register_diag_field('ice_shelf_model','shelf_speed',CS%diag%axesB1, Time, & + 'speed of of ice shelf', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesB1, Time, & 'x-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesB1, Time, & 'y-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_taud_shelf = register_diag_field('ice_shelf_model','taud_shelf',CS%diag%axesB1, Time, & + 'magnitude of driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_sx_shelf = register_diag_field('ice_shelf_model','sx_shelf',CS%diag%axesB1, Time, & + 'x-surface slope of ice', 'none') + CS%id_sy_shelf = register_diag_field('ice_shelf_model','sy_shelf',CS%diag%axesB1, Time, & + 'y-surface slope of ice', 'none') + CS%id_surf_slope_mag_shelf = register_diag_field('ice_shelf_model','surf_slope_mag_shelf', CS%diag%axesB1, Time, & + 'magnitude of surface slope of ice', 'none') CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesB1, Time, & 'mask for u-nodes', 'none') CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesB1, Time, & @@ -774,6 +841,42 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 'taub', 'MPa s m-1', conversion=1e-6*US%RL2_T2_to_Pa/(365.0*86400.0*US%L_T_to_m_s)) CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) + + CS%id_duHdx = register_diag_field('ice_shelf_model','duHdx',CS%diag%axesT1, Time, & + 'x-component of ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*US%Z_to_m*US%s_to_T) + CS%id_dvHdy = register_diag_field('ice_shelf_model','dvHdy',CS%diag%axesT1, Time, & + 'y-component of ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*US%Z_to_m*US%s_to_T) + CS%id_fluxdiv = register_diag_field('ice_shelf_model','fluxdiv',CS%diag%axesT1, Time, & + 'ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*US%Z_to_m*US%s_to_T) + CS%id_strainrate_xx = register_diag_field('ice_shelf_model','strainrate_xx',CS%diag%axesT1, Time, & + 'x-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_strainrate_yy = register_diag_field('ice_shelf_model','strainrate_yy',CS%diag%axesT1, Time, & + 'y-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_strainrate_xy = register_diag_field('ice_shelf_model','strainrate_xy',CS%diag%axesT1, Time, & + 'xy-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_pstrainrate_1 = register_diag_field('ice_shelf_model','pstrainrate_1',CS%diag%axesT1, Time, & + 'max principal horizontal ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_pstrainrate_2 = register_diag_field('ice_shelf_model','pstrainrate_2',CS%diag%axesT1, Time, & + 'min principal horizontal ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_devstress_xx = register_diag_field('ice_shelf_model','devstress_xx',CS%diag%axesT1, Time, & + 'x-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_devstress_yy = register_diag_field('ice_shelf_model','devstress_yy',CS%diag%axesT1, Time, & + 'y-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_devstress_xy = register_diag_field('ice_shelf_model','devstress_xy',CS%diag%axesT1, Time, & + 'xy-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_pdevstress_1 = register_diag_field('ice_shelf_model','pdevstress_1',CS%diag%axesT1, Time, & + 'max principal horizontal ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_pdevstress_2 = register_diag_field('ice_shelf_model','pdevstress_2',CS%diag%axesT1, Time, & + 'min principal ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + + !Update these variables so that they are nonzero in case + !IS_dynamics_post_data is called before update_ice_shelf + if (CS%id_taudx_shelf>0 .or. CS%id_taudy_shelf>0) & + call calc_shelf_driving_stress(CS, ISS, G, US, CS%taudx_shelf, CS%taudy_shelf, CS%OD_av) + if (CS%id_taub>0) & + call calc_shelf_taub(CS, ISS, G, US, CS%u_shelf, CS%v_shelf) + if (CS%id_visc_shelf>0) & + call calc_shelf_visc(CS, ISS, G, US, CS%u_shelf, CS%v_shelf) endif if (new_sim) then @@ -802,7 +905,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) do j=jsd,jed do i=isd,ied - OD = CS%bed_elev(i,j) - rhoi_rhow * ISS%h_shelf(i,j) + OD = CS%bed_elev(i,j) - rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating CS%OD_av(i,j) = OD @@ -834,10 +937,10 @@ function ice_time_step_CFL(CS, ISS, G) min_vel = (1.0e-12/(365.0*86400.0)) * G%US%m_s_to_L_T do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0 .or. ISS%hmask(i,j)==3) then dt_local = 2.0*G%areaT(i,j) / & - ((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel) + & - G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel)) + & - (G%dxCv(i,J) * max(abs(CS%v_shelf(i,J) + CS%v_shelf(i-1,J)), min_vel) + & - G%dxCv(i,J-1)* max(abs(CS%v_shelf(i,J-1)+ CS%v_shelf(i-1,J-1)), min_vel))) + (((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel)) + & + (G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel))) + & + ((G%dxCv(i,J) * max(abs(CS%v_shelf(i,J) + CS%v_shelf(i-1,J)), min_vel)) + & + (G%dxCv(i,J-1)* max(abs(CS%v_shelf(i,J-1)+ CS%v_shelf(i-1,J-1)), min_vel)))) min_dt = min(min_dt, dt_local) endif ; enddo ; enddo ! i- and j- loops @@ -850,7 +953,8 @@ end function ice_time_step_CFL !> This subroutine updates the ice shelf velocities, mass, stresses and properties due to the !! ice shelf dynamics. -subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled_grounding, must_update_vel) +subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, calve_ice_shelf_bergs, & + ocean_mass, coupled_grounding, must_update_vel) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -858,17 +962,14 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, intent(in) :: time_step !< time step [T ~> s] type(time_type), intent(in) :: Time !< The current model time + logical, intent(in) :: calve_ice_shelf_bergs !< To convert ice flux through front + !! to bergs real, dimension(SZDI_(G),SZDJ_(G)), & optional, intent(in) :: ocean_mass !< If present this is the mass per unit area !! of the ocean [R Z ~> kg m-2]. logical, optional, intent(in) :: coupled_grounding !< If true, the grounding line is !! determined by coupled ice-ocean dynamics logical, optional, intent(in) :: must_update_vel !< Always update the ice velocities if true. - real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y ! Pa] - real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc !< area-averaged vertically integrated ice viscosity - !! [R L2 Z T-1 ~> Pa s m] - real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged taub_beta field related to basal traction, - !! [R L1 T-1 ~> Pa s m-1] integer :: iters logical :: update_ice_vel, coupled_GL @@ -879,7 +980,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding ! if (CS%advect_shelf) then - call ice_shelf_advect(CS, ISS, G, time_step, Time) + call ice_shelf_advect(CS, ISS, G, time_step, Time, calve_ice_shelf_bergs) if (CS%alternate_first_direction_IS) then CS%first_direction_IS = modulo(CS%first_direction_IS+1,2) CS%first_dir_restart_IS = real(CS%first_direction_IS) @@ -897,62 +998,196 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (update_ice_vel) then call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + CS%elapsed_velocity_time = 0.0 endif ! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) - if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) then - call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) +end subroutine update_ice_shelf + +subroutine volume_above_floatation(CS, G, ISS, vaf, hemisphere) + type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + real, intent(out) :: vaf !< area integrated volume above floatation [m3] + integer, optional, intent(in) :: hemisphere !< 0 for Antarctica only, 1 for Greenland only. Otherwise, all ice sheets + integer :: IS_ID ! local copy of hemisphere + real, dimension(SZI_(G),SZJ_(G)) :: vaf_cell !< cell-wise volume above floatation [m3] + integer, dimension(SZI_(G),SZJ_(G)) :: mask ! a mask for active cells depending on hemisphere indicated + integer :: is,ie,js,je,i,j + real :: rhoi_rhow, rhow_rhoi + + if (CS%GL_couple) & + call MOM_error(FATAL, "MOM_ice_shelf_dyn, volume above floatation calculation assumes GL_couple=.FALSE..") + + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + rhow_rhoi = CS%density_ocean_avg / CS%density_ice + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (present(hemisphere)) then + IS_ID=hemisphere + else + IS_ID=-1 + endif + + mask(:,:)=0 + if (IS_ID==0) then !Antarctica (S. Hemisphere) only + do j = js,je; do i = is,ie + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)<=0.0) mask(i,j)=1 + enddo; enddo + elseif (IS_ID==1) then !Greenland (N. Hemisphere) only + do j = js,je; do i = is,ie + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)>0.0) mask(i,j)=1 + enddo; enddo + else !All ice sheets + mask(is:ie,js:je)=ISS%hmask(is:ie,js:je) + endif + + vaf_cell(:,:)=0.0 + do j = js,je; do i = is,ie + if (mask(i,j)>0) then + if (CS%bed_elev(i,j) <= 0) then + !grounded above sea level + vaf_cell(i,j)= (ISS%h_shelf(i,j) * G%US%Z_to_m) * (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) + else + !grounded if vaf_cell(i,j) > 0 + vaf_cell(i,j) = (max(ISS%h_shelf(i,j) - rhow_rhoi * CS%bed_elev(i,j), 0.0) * G%US%Z_to_m) * & + (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) + endif + endif + enddo; enddo + + vaf = reproducing_sum(vaf_cell) +end subroutine volume_above_floatation + +!> multiplies a variable with the ice sheet grounding fraction +subroutine masked_var_grounded(G,CS,var,varout) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< variable in + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: varout ! Ice shelf dynamics post_data calls +subroutine IS_dynamics_post_data(time_step, Time, CS, ISS, G) + real :: time_step !< Length of time for post data averaging [T ~> s]. + type(time_type), intent(in) :: Time !< The current model time + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y, taud ! area-averaged driving stress [R L2 T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! area-averaged vertically integrated ice viscosity + !! [R L2 Z T-1 ~> Pa s m] + real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr ! area-averaged taub_beta field related to basal traction, + !! [R L1 T-1 ~> Pa s m-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: surf_slope ! the surface slope of the ice shelf/sheet [nondim] + real, dimension(SZDIB_(G),SZDJB_(G)) :: ice_speed ! ice sheet flow speed [L T-1 ~> m s-1] + + integer :: i,j + call enable_averages(time_step, Time, CS%diag) if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) + if (CS%id_shelf_speed > 0) then + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + ice_speed(I,J) = sqrt((CS%u_shelf(I,J)**2) + (CS%v_shelf(I,J)**2)) + enddo ; enddo + call post_data(CS%id_shelf_speed, ice_speed, CS%diag) + endif ! if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf, CS%t_shelf, CS%diag) if (CS%id_taudx_shelf > 0) then - taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaBu(:,:) + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + taud_x(I,J) = CS%taudx_shelf(I,J)*G%IareaBu(I,J) + enddo ; enddo call post_data(CS%id_taudx_shelf, taud_x, CS%diag) endif if (CS%id_taudy_shelf > 0) then - taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaBu(:,:) + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + taud_y(I,J) = CS%taudy_shelf(I,J)*G%IareaBu(I,J) + enddo ; enddo call post_data(CS%id_taudy_shelf, taud_y, CS%diag) endif + if (CS%id_taud_shelf > 0) then + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + taud(I,J) = sqrt((CS%taudx_shelf(I,J)**2)+(CS%taudy_shelf(I,J)**2))*G%IareaBu(I,J) + enddo ; enddo + call post_data(CS%id_taud_shelf, taud, CS%diag) + endif + if (CS%id_sx_shelf > 0) call post_data(CS%id_sx_shelf, CS%sx_shelf, CS%diag) + if (CS%id_sy_shelf > 0) call post_data(CS%id_sy_shelf, CS%sy_shelf, CS%diag) + if (CS%id_surf_slope_mag_shelf > 0) then + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + surf_slope(I,J) = sqrt((CS%sx_shelf(I,J)**2)+(CS%sy_shelf(I,J)**2)) + enddo ; enddo + call post_data(CS%id_surf_slope_mag_shelf, surf_slope, CS%diag) + endif if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) if (CS%id_float_cond > 0) call post_data(CS%id_float_cond, CS%float_cond, CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) if (CS%id_visc_shelf > 0) then - if (CS%visc_qps==4) then - ice_visc(:,:) = (0.25 * G%IareaT(:,:)) * & - ((CS%ice_visc(:,:,1) + CS%ice_visc(:,:,4)) + (CS%ice_visc(:,:,2) + CS%ice_visc(:,:,3))) - else - ice_visc(:,:) = CS%ice_visc(:,:,1)*G%IareaT(:,:) - endif + call ice_visc_diag(CS,G,ice_visc) call post_data(CS%id_visc_shelf, ice_visc, CS%diag) endif if (CS%id_taub > 0) then - basal_tr(:,:) = CS%basal_traction(:,:)*G%IareaT(:,:) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + basal_tr(i,j) = CS%basal_traction(i,j)*G%IareaT(i,j) + enddo ; enddo call post_data(CS%id_taub, basal_tr, CS%diag) endif -!! if (CS%id_u_mask > 0) call post_data(CS%id_u_mask, CS%umask, CS%diag) if (CS%id_v_mask > 0) call post_data(CS%id_v_mask, CS%vmask, CS%diag) if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask, CS%u_face_mask_bdry, CS%diag) if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask, CS%v_face_mask_bdry, CS%diag) ! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask, CS%tmask, CS%diag) - call disable_averaging(CS%diag) + if (CS%id_duHdx > 0 .or. CS%id_dvHdy > 0 .or. CS%id_fluxdiv > 0 .or. & + CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & + CS%id_strainrate_xx > 0 .or. CS%id_strainrate_yy > 0 .or. CS%id_strainrate_xy > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0 .or. & + CS%id_pstrainrate_1 > 0 .or. CS%id_pstrainrate_2 > 0) then + call IS_dynamics_post_data_2(CS, ISS, G) + endif - CS%elapsed_velocity_time = 0.0 + call disable_averaging(CS%diag) +end subroutine IS_dynamics_post_data + +!> Calculate cell-centered, area-averaged, vertically integrated ice viscosity for diagnostics +subroutine ice_visc_diag(CS,G,ice_visc) + type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), intent(out) :: ice_visc !< area-averaged vertically integrated ice viscosity + !! [R L2 Z T-1 ~> Pa s m] + integer :: i,j + + ice_visc(:,:)=0.0 + if (CS%visc_qps==4) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ice_visc(i,j) = (0.25 * G%IareaT(i,j)) * & + ((CS%ice_visc(i,j,1) + CS%ice_visc(i,j,4)) + (CS%ice_visc(i,j,2) + CS%ice_visc(i,j,3))) + enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ice_visc(i,j) = CS%ice_visc(i,j,1)*G%IareaT(i,j) + enddo ; enddo endif - -end subroutine update_ice_shelf +end subroutine ice_visc_diag !> Writes the total ice shelf kinetic energy and mass to an ascii file -subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) +subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: mass !< The mass per unit area of the ice shelf !! or sheet [R Z ~> kg m-2] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: area !< The ice shelf or ice sheet area [L2 ~> m2] type(time_type), intent(in) :: day !< The current model time. type(time_type), optional, intent(in) :: time_step !< The current time step ! Local variables @@ -1011,9 +1246,9 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) tmp1(:,:)=0.0 KE_scale_factor = US%L_to_m**2 * (US%RZ_to_kg_m2 * US%L_T_to_m_s**2) do j=js,je ; do i=is,ie - tmp1(i,j) = (KE_scale_factor * 0.03125) * (G%areaT(i,j) * mass(i,j)) * & - (((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J))+(CS%u_shelf(I,J-1)+CS%u_shelf(I-1,J)))**2 + & - ((CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J))+(CS%v_shelf(I,J-1)+CS%v_shelf(I-1,J)))**2) + tmp1(i,j) = (KE_scale_factor * 0.03125) * (mass(i,j) * area(i,j)) * & + ((((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J))+(CS%u_shelf(I,J-1)+CS%u_shelf(I-1,J)))**2) + & + (((CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J))+(CS%v_shelf(I,J-1)+CS%v_shelf(I-1,J)))**2)) enddo; enddo KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) @@ -1022,7 +1257,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) tmp1(:,:)=0.0 mass_scale_factor = US%L_to_m**2 * US%RZ_to_kg_m2 do j=js,je ; do i=is,ie - tmp1(i,j) = mass_scale_factor * (mass(i,j) * G%areaT(i,j)) + tmp1(i,j) = mass_scale_factor * (mass(i,j) * area(i,j)) enddo; enddo mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) @@ -1033,7 +1268,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) else call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=WRITEONLY_FILE) if (abs(CS%timeunit - 86400.0) < 1.0) then - write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Day,"8x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Day,",8x,"Energy/Mass,",13x,"Total Mass")') write(CS%IS_fileenergy_ascii,'(12x,"[days]",10x,"[m2 s-2]",17x,"[kg]")') else if ((CS%timeunit >= 0.99) .and. (CS%timeunit < 1.01)) then @@ -1048,7 +1283,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) write(time_units,'(9x,"[",es8.2," s] ")') CS%timeunit endif - write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Time,"7x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Time,",7x,"Energy/Mass,",13x,"Total Mass")') write(CS%IS_fileenergy_ascii,'(A25,3x,"[m2 s-2]",17x,"[kg]")') time_units endif endif @@ -1080,14 +1315,15 @@ end subroutine write_ice_shelf_energy !> This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. !! Additionally, it will update the volume of ice in partially-filled cells, and update !! hmask accordingly -subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) +subroutine ice_shelf_advect(CS, ISS, G, time_step, Time, calve_ice_shelf_bergs) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. real, intent(in) :: time_step !< time step [T ~> s] type(time_type), intent(in) :: Time !< The current model time - + logical, intent(in) :: calve_ice_shelf_bergs !< If true, track ice shelf flux through a + !! static ice shelf, so that it can be converted into icebergs ! 3/8/11 DNG ! @@ -1155,10 +1391,27 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) if (CS%calve_to_mask) then call calve_to_mask(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%calve_mask) endif + elseif (calve_ice_shelf_bergs) then + !advect the front to create partially-filled cells + call shelf_advance_front(CS, ISS, G, ISS%hmask, uh_ice, vh_ice) + !add mass of the partially-filled cells to calving field, which is used to initialize icebergs + !Then, remove the partially-filled cells from the ice shelf + ISS%calving(:,:)=0.0 + ISS%calving_hflx(:,:)=0.0 + do j=jsc,jec; do i=isc,iec + if (ISS%hmask(i,j)==2) then + ISS%calving(i,j) = (ISS%h_shelf(i,j) * CS%density_ice) * & + (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) / time_step + ISS%calving_hflx(i,j) = (CS%Cp_ice * CS%t_shelf(i,j)) * & + ((ISS%h_shelf(i,j) * CS%density_ice) * & + (ISS%area_shelf_h(i,j) * G%IareaT(i,j))) + ISS%h_shelf(i,j) = 0.0; ISS%area_shelf_h(i,j) = 0.0; ISS%hmask(i,j) = 0.0 + endif + enddo; enddo endif do j=jsc,jec; do i=isc,iec - ISS%mass_shelf(i,j) = (ISS%h_shelf(i,j) * CS%density_ice) * (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice enddo; enddo call pass_var(ISS%mass_shelf, G%domain, complete=.false.) @@ -1198,14 +1451,18 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! the grounding line (float_cond=1) or not (float_cond=0) real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Used for convergence character(len=160) :: mesg ! The text of an error message - integer :: conv_flag, i, j, k,l, iter - integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat + integer :: conv_flag, i, j, k,l, iter, nodefloat + integer :: Isdq, Iedq, Jsdq, Jedq, isd, ied, jsd, jed + integer :: Iscq, Iecq, Jscq, Jecq, isc, iec, jsc, jec real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv, Norm, PrevNorm real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. + integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec rhoi_rhow = CS%density_ice / CS%density_ocean_avg taudx(:,:) = 0.0 ; taudy(:,:) = 0.0 @@ -1217,7 +1474,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (.not. CS%GL_couple) then do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) > 0) then + if (rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) > 0) then CS%ground_frac(i,j) = 1.0 CS%OD_av(i,j) =0.0 endif @@ -1235,7 +1492,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (CS%GL_regularize) then - call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node) + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node, CS%min_h_shelf) do j=G%jsc,G%jec ; do i=G%isc,G%iec nodefloat = 0 @@ -1253,6 +1510,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i enddo ; enddo call pass_var(CS%float_cond, G%Domain, complete=.false.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) endif @@ -1282,7 +1540,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) err_init = 0 ; err_tempu = 0 ; err_tempv = 0 - do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB + do J=G%JscB,G%JecB ; do I=G%IscB,G%IecB if (CS%umask(I,J) == 1) then err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_init) err_init = err_tempu @@ -1296,20 +1554,25 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call max_across_PEs(err_init) elseif (CS%nonlin_solve_err_mode == 3) then Normvec=0.0 + ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. - Is_sum = G%isc + (1-G%IsdB) - Ie_sum = G%iecB + (1-G%IsdB) - ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. - if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) - - Js_sum = G%jsc + (1-G%JsdB) - Je_sum = G%jecB + (1-G%JsdB) - ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. - if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) - do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + ! Includes the edge of the tile is at the western/southern bdry (if symmetric) + if ((isc+G%idg_offset==G%isg) .and. (.not. CS%reentrant_x)) then + Is_sum = Iscq + (1-Isdq) ; Iscq_sv = Iscq + else + Is_sum = isc + (1-Isdq) ; Iscq_sv = isc + endif + if ((jsc+G%jdg_offset==G%jsg) .and. (.not. CS%reentrant_y)) then + Js_sum = Jscq + (1-Jsdq) ; Jscq_sv = Jscq + else + Js_sum = jsc + (1-Jsdq) ; Jscq_sv = jsc + endif + Ie_sum = Iecq + (1-Isdq) ; Je_sum = Jecq + (1-Jsdq) + + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (u_shlf(I,J)**2 * US%L_T_to_m_s**2) if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2 * US%L_T_to_m_s**2) - enddo; enddo + enddo ; enddo Norm = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) Norm = sqrt(Norm) endif @@ -1324,8 +1587,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ISS%hmask, conv_flag, iters, time, CS%Phi, CS%Phisub) if (CS%debug) then - call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) - call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) + call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, unscale=US%L_T_to_m_s) + call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, unscale=US%L_T_to_m_s) endif write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" @@ -1359,7 +1622,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i err_max = 0 - do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB if (CS%umask(I,J) == 1) then err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_max) err_max = err_tempu @@ -1386,7 +1649,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (CS%vmask(I,J) == 1) then err_tempv = MAX(ABS(v_last(I,J)-v_shlf(I,J)), err_tempu) if (err_tempv >= err_max) err_max = err_tempv - tempv = SQRT(v_shlf(I,J)**2 + tempu**2) + tempv = SQRT((v_shlf(I,J)**2) + (tempu**2)) endif if (tempv >= max_vel) max_vel = tempv enddo ; enddo @@ -1400,7 +1663,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i elseif (CS%nonlin_solve_err_mode == 3) then PrevNorm=Norm; Norm=0.0; Normvec=0.0 - do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (u_shlf(I,J)**2 * US%L_T_to_m_s**2) if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2 * US%L_T_to_m_s**2) enddo; enddo @@ -1462,7 +1725,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! one linear solve (nonlinear iteration) of the solution for velocity ! in this subroutine: -! boundary contributions are added to taud to get the RHS +! RHS = taud ! diagonal of matrix is found (for Jacobi precondition) ! CG iteration is carried out for max. iterations or until convergence @@ -1477,9 +1740,9 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] Du, Dv, & ! Velocity changes [L T-1 ~> m s-1] - sum_vec, sum_vec_2 !, & + sum_vec, sum_vec_2, sum_vec_3 !, & !ubd, vbd ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2] - real :: beta_k, dot_p1, resid0, cg_halo + real :: beta_k, dot_p1, resid0tol2, cg_halo, max_cg_halo real :: alpha_k ! A scaling factor for iterative corrections [nondim] real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] @@ -1488,10 +1751,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] integer :: iter, i, j, isd, ied, jsd, jed, isc, iec, jsc, jec, is, js, ie, je integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. - integer :: isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo + integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq, nx_halo, ny_halo + integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec @@ -1504,18 +1768,20 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H dot_p1 = 0 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. - Is_sum = G%isc + (1-G%IsdB) - Ie_sum = G%iecB + (1-G%IsdB) - ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. - if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) - - Js_sum = G%jsc + (1-G%JsdB) - Je_sum = G%jecB + (1-G%JsdB) - ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. - if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) + ! Includes the edge of the tile is at the western/southern bdry (if symmetric) + if ((isc+G%idg_offset==G%isg) .and. (.not. CS%reentrant_x)) then + Is_sum = Iscq + (1-Isdq) ; Iscq_sv = Iscq + else + Is_sum = isc + (1-Isdq) ; Iscq_sv = isc + endif + if ((jsc+G%jdg_offset==G%jsg) .and. (.not. CS%reentrant_y)) then + Js_sum = Jscq + (1-Jsdq) ; Jscq_sv = Jscq + else + Js_sum = jsc + (1-Jsdq) ; Jscq_sv = jsc + endif + Ie_sum = Iecq + (1-Isdq) ; Je_sum = Jecq + (1-Jsdq) - RHSu(:,:) = taudx(:,:) - RHSv(:,:) = taudy(:,:) + RHSu(:,:) = taudx(:,:) ; RHSv(:,:) = taudy(:,:) call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE, complete=.false.) @@ -1530,31 +1796,32 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE, complete=.true.) - Ru(:,:) = (RHSu(:,:) - Au(:,:)) - Rv(:,:) = (RHSv(:,:) - Av(:,:)) + Ru(:,:) = (RHSu(:,:) - Au(:,:)) ; Rv(:,:) = (RHSv(:,:) - Av(:,:)) resid_scale = (US%L_to_m**2*US%s_to_T)*(US%RZ_to_kg_m2*US%L_T_to_m_s**2) resid2_scale = ((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2 sum_vec(:,:) = 0.0 - do j=jscq,jecq ; do i=iscq,iecq + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 enddo ; enddo - dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) - - resid0 = sqrt(dot_p1) + !resid0 = sqrt(reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum )) + resid0tol2 = CS%cg_tolerance**2 * reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) - do j=jsdq,jedq - do i=isdq,iedq - if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) Zu(I,J) = Ru(I,J) / DIAGu(I,J) - if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) Zv(I,J) = Rv(I,J) / DIAGv(I,J) - enddo - enddo + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) Zu(I,J) = Ru(I,J) / DIAGu(I,J) + if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) Zv(I,J) = Rv(I,J) / DIAGv(I,J) + enddo ; enddo Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) - cg_halo = 3 + if (G%symmetric) then + max_cg_halo=min(nx_halo,ny_halo) + else + max_cg_halo=min(nx_halo,ny_halo)-1 + endif + cg_halo = max_cg_halo conv_flag = 0 !!!!!!!!!!!!!!!!!! @@ -1567,13 +1834,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do iter = 1,CS%cg_max_iterations - ! assume asymmetry - ! thus we can never assume that any arrays are legit more than 3 vertices past + ! we can never assume that any arrays are legit more than 3 vertices past ! the computational domain - this is their state in the initial iteration - - is = iscq - cg_halo ; ie = iecq + cg_halo - js = jscq - cg_halo ; je = jecq + cg_halo + is = isc - cg_halo ; ie = Iecq + cg_halo + js = jsc - cg_halo ; je = Jecq + cg_halo Au(:,:) = 0 ; Av(:,:) = 0 @@ -1587,98 +1852,68 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - do j=jscq,jecq ; do i=iscq,iecq + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) sum_vec_2(I,J) = resid_scale * (Du(I,J) * Au(I,J)) + Ru_old(I,J) = Ru(I,J) ; Zu_old(I,J) = Zu(I,J) endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Dv(I,J) * Av(I,J)) + Rv_old(I,J) = Rv(I,J) ; Zv_old(I,J) = Zv(I,J) endif enddo ; enddo alpha_k = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & reproducing_sum( sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) - - do j=jsd,jed ; do i=isd,ied - if (CS%umask(I,J) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) - if (CS%vmask(I,J) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(I,J) - enddo ; enddo - - do j=jsd,jed ; do i=isd,ied + do J=js,je-1 ; do I=is,ie-1 if (CS%umask(I,J) == 1) then - Ru_old(I,J) = Ru(I,J) ; Zu_old(I,J) = Zu(I,J) + u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) + Ru(I,J) = Ru(I,J) - alpha_k * Au(I,J) + if (DIAGu(I,J)/=0) Zu(I,J) = Ru(I,J) / DIAGu(I,J) endif if (CS%vmask(I,J) == 1) then - Rv_old(I,J) = Rv(I,J) ; Zv_old(I,J) = Zv(I,J) + v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(I,J) + Rv(I,J) = Rv(I,J) - alpha_k * Av(I,J) + if (DIAGv(I,J)/=0) Zv(I,J) = Rv(I,J) / DIAGv(I,J) endif - enddo ; enddo - -! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) -! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) - - do j=jsd,jed - do i=isd,ied - if (CS%umask(I,J) == 1) Ru(I,J) = Ru(I,J) - alpha_k * Au(I,J) - if (CS%vmask(I,J) == 1) Rv(I,J) = Rv(I,J) - alpha_k * Av(I,J) - enddo - enddo + enddo; enddo - do j=jsdq,jedq - do i=isdq,iedq - if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) then - Zu(I,J) = Ru(I,J) / DIAGu(I,J) - endif - if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) then - Zv(I,J) = Rv(I,J) / DIAGv(I,J) - endif - enddo - enddo ! R,u,v,Z valid region moves in by 1 ! beta_k = (Z \dot R) / (Zold \dot Rold) - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 ; sum_vec_3(:,:) = 0.0 - do j=jscq,jecq ; do i=iscq,iecq + do J=jscq_sv,jecq ; do i=iscq_sv,iecq if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) - sum_vec_2(I,J) = resid_scale * (Zu_old(I,J) * Ru_old(I,J)) + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_2(I,J) = resid_scale * (Zu_old(I,J) * Ru_old(I,J)) + sum_vec_3(I,J) = resid2_scale * Ru(I,J)**2 endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) - sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Zv_old(I,J) * Rv_old(I,J)) + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Zv_old(I,J) * Rv_old(I,J)) + sum_vec_3(I,J) = sum_vec_3(I,J) + resid2_scale * Rv(I,J)**2 endif enddo ; enddo beta_k = reproducing_sum(sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & reproducing_sum(sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) -! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) -! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) - - do j=jsd,jed - do i=isd,ied + do J=js,je-1 ; do I=is,ie-1 if (CS%umask(I,J) == 1) Du(I,J) = Zu(I,J) + beta_k * Du(I,J) if (CS%vmask(I,J) == 1) Dv(I,J) = Zv(I,J) + beta_k * Dv(I,J) - enddo - enddo - - ! D valid region moves in by 1 - - sum_vec(:,:) = 0.0 - do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 - if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 enddo ; enddo - dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) - dot_p1 = sqrt(dot_p1) + ! D valid region moves in by 1 + dot_p1 = reproducing_sum( sum_vec_3, Is_sum, Ie_sum, Js_sum, Je_sum ) - if (dot_p1 <= (CS%cg_tolerance * resid0)) then + !if sqrt(dot_p1) <= (CS%cg_tolerance * resid0) + if (dot_p1 <= resid0tol2) then iters = iter conv_flag = 1 exit @@ -1691,13 +1926,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE, complete=.false.) call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE, complete=.false.) call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE, complete=.true.) - cg_halo = 3 + cg_halo = max_cg_halo endif enddo ! end of CG loop - do j=jsdq,jedq - do i=isdq,iedq + do J=Jsdq,Jedq ; do I=Isdq,Iedq if (CS%umask(I,J) == 3) then u_shlf(I,J) = CS%u_bdry_val(I,J) elseif (CS%umask(I,J) == 0) then @@ -1709,8 +1943,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H elseif (CS%vmask(I,J) == 0) then v_shlf(I,J) = 0 endif - enddo - enddo + enddo ; enddo call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) if (conv_flag == 0) then @@ -1747,7 +1980,6 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after ! is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ! isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed -! i_off = G%idg_offset ; j_off = G%jdg_offset ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1973,16 +2205,19 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) iter_count = iter_count + 1 ! if iter_count >= 3 then some halo updates need to be done... + if (iter_count==3) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, shelf_advance_front iter >=3.") + endif do j=jsc-1,jec+1 - if (((j+j_off) <= G%domain%njglobal) .AND. & - ((j+j_off) >= 1)) then + if (CS%reentrant_y .OR. (((j+j_off) <= G%domain%njglobal) .AND. & + ((j+j_off) >= 1))) then do i=isc-1,iec+1 - if (((i+i_off) <= G%domain%niglobal) .AND. & - ((i+i_off) >= 1)) then + if (CS%reentrant_x .OR. (((i+i_off) <= G%domain%niglobal) .AND. & + ((i+i_off) >= 1))) then ! first get reference thickness by averaging over cells that are fluxing into this cell n_flux = 0 h_reference_ew = 0.0 @@ -2174,7 +2409,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] real :: dxh, dyh,Dx,Dy ! Local grid spacing [L ~> m] real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - + real :: scale ! Scaling factor used to ensure surface slope magnitude does not exceed CS%max_surface_slope integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, is, js, iegq, jegq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec integer :: i_off, j_off @@ -2200,17 +2435,17 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) if (CS%GL_couple) then do j=jsc-G%domain%njhalo,jec+G%domain%njhalo do i=isc-G%domain%nihalo,iec+G%domain%nihalo - S(i,j) = -CS%bed_elev(i,j) + (OD(i,j) + ISS%h_shelf(i,j)) + S(i,j) = -CS%bed_elev(i,j) + (OD(i,j) + max(ISS%h_shelf(i,j),CS%min_h_shelf)) enddo enddo else ! check whether the ice is floating or grounded do j=jsc-G%domain%njhalo,jec+G%domain%njhalo do i=isc-G%domain%nihalo,iec+G%domain%nihalo - if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then - S(i,j) = (1 - rhoi_rhow)*ISS%h_shelf(i,j) + if (rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) <= 0) then + S(i,j) = (1 - rhoi_rhow)*max(ISS%h_shelf(i,j),CS%min_h_shelf) else - S(i,j) = ISS%h_shelf(i,j)-CS%bed_elev(i,j) + S(i,j) = max(ISS%h_shelf(i,j),CS%min_h_shelf)-CS%bed_elev(i,j) endif enddo enddo @@ -2233,13 +2468,13 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! we are inside the global computational bdry, at an ice-filled cell ! calculate sx - if ((i+i_off) == gisc) then ! at west computational bdry + if (((i+i_off) == gisc) .and. (.not. CS%reentrant_x)) then ! at west computational bdry if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then sx = (S(i+1,j)-S(i,j))/dxh else sx = 0 endif - elseif ((i+i_off) == giec) then ! at east computational bdry + elseif (((i+i_off) == giec) .and. (.not. CS%reentrant_x)) then ! at east computational bdry if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then sx = (S(i,j)-S(i-1,j))/dxh else @@ -2270,13 +2505,13 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) cnt = 0 ! calculate sy, similarly - if ((j+j_off) == gjsc) then ! at south computational bdry + if (((j+j_off) == gjsc) .and. (.not. CS%reentrant_y)) then ! at south computational bdry if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then sy = (S(i,j+1)-S(i,j))/dyh else sy = 0 endif - elseif ((j+j_off) == gjec) then ! at north computational bdry + elseif (((j+j_off) == gjec) .and. (.not. CS%reentrant_y)) then ! at north computational bdry if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then sy = (S(i,j)-S(i,j-1))/dyh else @@ -2304,17 +2539,24 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif endif - sx_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (ISS%h_shelf(i,j) * sx)) - sy_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (ISS%h_shelf(i,j) * sy)) + if (CS%max_surface_slope>0) then + scale = min(CS%max_surface_slope/sqrt((sx**2)+(sy**2)),1.0) + sx = scale*sx; sy = scale*sy + endif + + sx_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) * sx)) + sy_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) * sy)) + + CS%sx_shelf(i,j) = sx ; CS%sy_shelf(i,j) = sy !Stress (Neumann) boundary conditions if (CS%ground_frac(i,j) == 1) then - neumann_val = ((.5 * grav) * (rho * ISS%h_shelf(i,j)**2 - rhow * CS%bed_elev(i,j)**2)) + neumann_val = ((.5 * grav) * (rho * max(ISS%h_shelf(i,j),CS%min_h_shelf)**2 - rhow * CS%bed_elev(i,j)**2)) else - neumann_val = (.5 * grav) * ((1-rho/rhow) * (rho * ISS%h_shelf(i,j)**2)) + neumann_val = (.5 * grav) * ((1-rho/rhow) * (rho * max(ISS%h_shelf(i,j),CS%min_h_shelf)**2)) endif if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. & - ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (i+i_off /= gisc))) then + ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (CS%reentrant_x .OR. (i+i_off /= gisc)))) then ! left face of the cell is at a stress boundary ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated ! pressure on either side of the face @@ -2329,21 +2571,21 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif if ((CS%u_face_mask_bdry(I,j) == 2) .OR. & - ((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (i+i_off /= giec))) then + ((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (CS%reentrant_x .OR. (i+i_off /= giec)))) then ! east face of the cell is at a stress boundary taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val endif if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. & - ((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (j+j_off /= gjsc))) then + ((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (CS%reentrant_y .OR. (j+j_off /= gjsc)))) then ! south face of the cell is at a stress boundary taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val endif if ((CS%v_face_mask_bdry(i,J) == 2) .OR. & - ((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (j+j_off /= gjec))) then + ((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (CS%reentrant_y .OR. (j+j_off /= gjec)))) then ! north face of the cell is at a stress boundary taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val @@ -2358,76 +2600,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) enddo; enddo end subroutine calc_shelf_driving_stress -! Not used? Seems to be only set up to work for a specific test case with u_face_mask==3 -subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) - type(ice_shelf_dyn_CS),intent(inout) :: CS !< A pointer to the ice shelf control structure - type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - type(time_type), intent(in) :: Time !< The current model time - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf - real, intent(in) :: input_flux !< The integrated inward ice thickness flux per - !! unit face length [Z L T-1 ~> m2 s-1] - real, intent(in) :: input_thick !< The ice thickness at boundaries [Z ~> m]. - logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - -! FOR RESTARTING PURPOSES: if grid is not symmetric and the model is restarted, we will -! need to update those velocity points not *technically* in any -! computational domain -- if this function gets moves to another module, -! DO NOT TAKE THE RESTARTING BIT WITH IT - integer :: i, j , isd, jsd, ied, jed - integer :: isc, jsc, iec, jec - integer :: i_off, j_off - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - ! this loop results in some values being set twice but... eh. - - do j=jsd,jed - do i=isd,ied - - if (hmask(i,j) == 3) then - CS%h_bdry_val(i,j) = input_thick - endif - - if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then - if ((i <= iec).and.(i >= isc)) then - if (CS%u_face_mask(I-1,j) == 3) then - CS%u_bdry_val(I-1,J-1) = (1 - ((G%geoLatBu(I-1,J-1) - 0.5*G%len_lat)*2./G%len_lat)**2) * & - 1.5 * input_flux / input_thick - CS%u_bdry_val(I-1,J) = (1 - ((G%geoLatBu(I-1,J) - 0.5*G%len_lat)*2./G%len_lat)**2) * & - 1.5 * input_flux / input_thick - endif - endif - endif - - if (.not.(new_sim)) then - if (.not. G%symmetric) then - if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) - endif - if (((j+j_off) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,J-1) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) - endif - endif - endif - enddo - enddo - -end subroutine init_boundary_values - - subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio) @@ -2461,8 +2633,7 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, !! partly or fully covered by an ice-shelf real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form - !! and units depend on the basal law exponent. + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice !! shelf is floating: 0 if floating, 1 if not @@ -2529,53 +2700,53 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, qp = 2*(jq-1)+iq !current quad point - uq = (u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & - u_shlf(I,J) * (xquad(iq) * xquad(jq))) + & - (u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & - u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq))) + uq = ((u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq))) + & + (u_shlf(I,J) * (xquad(iq) * xquad(jq)))) + & + ((u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq))) + & + (u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)))) - vq = (v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & - v_shlf(I,J) * (xquad(iq) * xquad(jq))) + & - (v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & - v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq))) + vq = ((v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq))) + & + (v_shlf(I,J) * (xquad(iq) * xquad(jq)))) + & + ((v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq))) + & + (v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)))) - ux = (u_shlf(I-1,J-1) * Phi(1,qp,i,j) + & - u_shlf(I,J) * Phi(7,qp,i,j)) + & - (u_shlf(I,J-1) * Phi(3,qp,i,j) + & - u_shlf(I-1,J) * Phi(5,qp,i,j)) + ux = ((u_shlf(I-1,J-1) * Phi(1,qp,i,j)) + & + (u_shlf(I,J) * Phi(7,qp,i,j))) + & + ((u_shlf(I,J-1) * Phi(3,qp,i,j)) + & + (u_shlf(I-1,J) * Phi(5,qp,i,j))) - vx = (v_shlf(I-1,J-1) * Phi(1,qp,i,j) + & - v_shlf(I,J) * Phi(7,qp,i,j)) + & - (v_shlf(I,J-1) * Phi(3,qp,i,j) + & - v_shlf(I-1,J) * Phi(5,qp,i,j)) + vx = ((v_shlf(I-1,J-1) * Phi(1,qp,i,j)) + & + (v_shlf(I,J) * Phi(7,qp,i,j))) + & + ((v_shlf(I,J-1) * Phi(3,qp,i,j)) + & + (v_shlf(I-1,J) * Phi(5,qp,i,j))) - uy = (u_shlf(I-1,J-1) * Phi(2,qp,i,j) + & - u_shlf(I,J) * Phi(8,qp,i,j)) + & - (u_shlf(I,J-1) * Phi(4,qp,i,j) + & - u_shlf(I-1,J) * Phi(6,qp,i,j)) + uy = ((u_shlf(I-1,J-1) * Phi(2,qp,i,j)) + & + (u_shlf(I,J) * Phi(8,qp,i,j))) + & + ((u_shlf(I,J-1) * Phi(4,qp,i,j)) + & + (u_shlf(I-1,J) * Phi(6,qp,i,j))) - vy = (v_shlf(I-1,J-1) * Phi(2,qp,i,j) + & - v_shlf(I,J) * Phi(8,qp,i,j)) + & - (v_shlf(I,J-1) * Phi(4,qp,i,j) + & - v_shlf(I-1,J) * Phi(6,qp,i,j)) + vy = ((v_shlf(I-1,J-1) * Phi(2,qp,i,j)) + & + (v_shlf(I,J) * Phi(8,qp,i,j))) + & + ((v_shlf(I,J-1) * Phi(4,qp,i,j)) + & + (v_shlf(I-1,J) * Phi(6,qp,i,j))) if (visc_qp4) qpv = qp !current quad point for viscosity do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * & - ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + (((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * & - ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + (((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) if (float_cond(i,j) == 0) then ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & - (basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq)) + ((basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq))) if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + & - (basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq)) + ((basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq))) endif enddo ; enddo enddo ; enddo @@ -2653,13 +2824,13 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, uloc_arr(:,:,:,:) = 0.0; vloc_arr(:,:,:,:)=0.0 do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2 - hloc = (Phisub(qx,qy,i,j,1,1)*H(1,1) + Phisub(qx,qy,i,j,2,2)*H(2,2)) + & - (Phisub(qx,qy,i,j,1,2)*H(1,2) + Phisub(qx,qy,i,j,2,1)*H(2,1)) + hloc = ((Phisub(qx,qy,i,j,1,1)*H(1,1)) + (Phisub(qx,qy,i,j,2,2)*H(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*H(1,2)) + (Phisub(qx,qy,i,j,2,1)*H(2,1))) if (dens_ratio * hloc - bathyT > 0) then - uloc_arr(qx,qy,i,j) = ((Phisub(qx,qy,i,j,1,1) * U(1,1) + Phisub(qx,qy,i,j,2,2) * U(2,2)) + & - (Phisub(qx,qy,i,j,1,2) * U(1,2) + Phisub(qx,qy,i,j,2,1) * U(2,1))) - vloc_arr(qx,qy,i,j) = ((Phisub(qx,qy,i,j,1,1) * V(1,1) + Phisub(qx,qy,i,j,2,2) * V(2,2)) + & - (Phisub(qx,qy,i,j,1,2) * V(1,2) + Phisub(qx,qy,i,j,2,1) * V(2,1))) + uloc_arr(qx,qy,i,j) = (((Phisub(qx,qy,i,j,1,1) * U(1,1)) + (Phisub(qx,qy,i,j,2,2) * U(2,2))) + & + ((Phisub(qx,qy,i,j,1,2) * U(1,2)) + (Phisub(qx,qy,i,j,2,1) * U(2,1)))) + vloc_arr(qx,qy,i,j) = (((Phisub(qx,qy,i,j,1,1) * V(1,1)) + (Phisub(qx,qy,i,j,2,2) * V(2,2))) + & + ((Phisub(qx,qy,i,j,1,2) * V(1,2)) + (Phisub(qx,qy,i,j,2,1) * V(2,1)))) endif enddo; enddo ; enddo ; enddo @@ -2738,12 +2909,10 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! (corner) points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form - !! and units depend on the basal law exponent. + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -2812,8 +2981,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, vy = 0. u_diag_qp(iphi,jphi,qp) = & - ice_visc(i,j,qpv) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + ice_visc(i,j,qpv) * (((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) @@ -2830,8 +2999,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, uy = 0. v_diag_qp(iphi,jphi,qp) = & - ice_visc(i,j,qpv) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + ice_visc(i,j,qpv) * (((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) if (float_cond(i,j) == 0) then vq = xquad(ilq) * xquad(jlq) @@ -2862,15 +3031,15 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_diagonal_subgrid_basal(Phisub, Hcell, CS%bed_elev(i,j), dens_ratio, sub_ground) - if (CS%umask(I-1,J-1) == 1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + sub_ground(1,1) * basal_trac(i,j) - if (CS%umask(I-1,J ) == 1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + sub_ground(1,2) * basal_trac(i,j) - if (CS%umask(I ,J-1) == 1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + sub_ground(2,1) * basal_trac(i,j) - if (CS%umask(I ,J ) == 1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + sub_ground(2,2) * basal_trac(i,j) + if (CS%umask(I-1,J-1) == 1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + (sub_ground(1,1) * basal_trac(i,j)) + if (CS%umask(I-1,J ) == 1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + (sub_ground(1,2) * basal_trac(i,j)) + if (CS%umask(I ,J-1) == 1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + (sub_ground(2,1) * basal_trac(i,j)) + if (CS%umask(I ,J ) == 1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + (sub_ground(2,2) * basal_trac(i,j)) - if (CS%vmask(I-1,J-1) == 1) v_diag_b(I-1,J-1,4) = v_diag_b(I-1,J-1,4) + sub_ground(1,1) * basal_trac(i,j) - if (CS%vmask(I-1,J ) == 1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + sub_ground(1,2) * basal_trac(i,j) - if (CS%vmask(I ,J-1) == 1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + sub_ground(2,1) * basal_trac(i,j) - if (CS%vmask(I ,J ) == 1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + sub_ground(2,2) * basal_trac(i,j) + if (CS%vmask(I-1,J-1) == 1) v_diag_b(I-1,J-1,4) = v_diag_b(I-1,J-1,4) + (sub_ground(1,1) * basal_trac(i,j)) + if (CS%vmask(I-1,J ) == 1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + (sub_ground(1,2) * basal_trac(i,j)) + if (CS%vmask(I ,J-1) == 1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + (sub_ground(2,1) * basal_trac(i,j)) + if (CS%vmask(I ,J ) == 1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + (sub_ground(2,2) * basal_trac(i,j)) endif endif ; enddo ; enddo @@ -2907,8 +3076,8 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, f_grnd grnd_stat(:,:,:,:)=0 do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2 - hloc = (Phisub(qx,qy,i,j,1,1)*H_node(1,1) + Phisub(qx,qy,i,j,2,2)*H_node(2,2)) + & - (Phisub(qx,qy,i,j,1,2)*H_node(1,2) + Phisub(qx,qy,i,j,2,1)*H_node(2,1)) + hloc = ((Phisub(qx,qy,i,j,1,1)*H_node(1,1)) + (Phisub(qx,qy,i,j,2,2)*H_node(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*H_node(1,2)) + (Phisub(qx,qy,i,j,2,1)*H_node(2,1))) if (dens_ratio * hloc - bathyT > 0) grnd_stat(qx,qy,i,j) = 1 enddo; enddo ; enddo ; enddo @@ -2927,6 +3096,140 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, f_grnd end subroutine CG_diagonal_subgrid_basal +!> Post_data calls related to ice-sheet flux divergence, strain-rate, and deviatoric stress +subroutine IS_dynamics_post_data_2(CS, ISS, G) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. + real, dimension(SZDIB_(G),SZDJB_(G)) :: Hu ! Ice shelf u_flux at corners [Z L T-1 ~> m2 s-1]. + real, dimension(SZDIB_(G),SZDJB_(G)) :: Hv ! Ice shelf v_flux at corners [Z L T-1 ~> m2 s-1]. + real, dimension(SZDI_(G),SZDJ_(G)) :: Hux ! Ice shelf d(u_flux)/dx at cell centers [Z T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)) :: Hvy ! Ice shelf d(v_flux)/dy at cell centers [Z T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)) :: flux_div ! horizontal flux divergence div(uH) [Z T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G),3) :: strain_rate ! strain-rate components xx,yy, and xy [T-1 ~> s-1] + real, dimension(SZDI_(G),SZDJ_(G),2) :: p_strain_rate ! horizontal principal strain-rates [T-1 ~> s-1] + real, dimension(SZDI_(G),SZDJ_(G),3) :: dev_stress ! deviatoric stress components xx,yy, and xy [R L Z T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G),2) :: p_dev_stress ! horizontal principal deviatoric stress [R L Z T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! area-averaged ice viscosity [R L2 T-1 ~> Pa s] + real :: p1,p2 ! Used to calculate strain-rate principal components [T-1 ~> s-1] + integer :: i, j + + !Allocate the gradient basis functions for 1 cell-centered quadrature point per cell + if (.not. associated(CS%PhiC)) then + allocate(CS%PhiC(1:8,G%isc:G%iec,G%jsc:G%jec), source=0.0) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call bilinear_shape_fn_grid_1qp(G, i, j, CS%PhiC(:,i,j)) + enddo; enddo + endif + + !Calculate flux divergence and its components + if (CS%id_duHdx > 0 .or. CS%id_dvHdy > 0 .or. CS%id_fluxdiv > 0) then + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node, CS%min_h_shelf) + + Hu(:,:) = 0.0; Hv(:,:) = 0.0; Hux(:,:) = 0.0 ; Hvy(:,:) = 0.0 ; flux_div(:,:) = 0.0 + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) > 0) then + Hu(I,J) = (H_node(I,J) * CS%u_shelf(I,J)) + endif + if (CS%vmask(I,J) > 0) then + Hv(I,J) = (H_node(I,J) * CS%v_shelf(I,J)) + endif + enddo; enddo + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 3)) then + !components of flux divergence at cell centers + Hux(i,j) = (((Hu(I-1,J-1) * CS%PhiC(1,i,j)) + (Hu(I,J ) * CS%PhiC(7,i,j))) + & + ((Hu(I-1,J ) * CS%PhiC(5,i,j)) + (Hu(I,J-1) * CS%PhiC(3,i,j)))) + + Hvy(i,j) = (((Hv(I-1,J-1) * CS%PhiC(2,i,j)) + (Hv(I,J ) * CS%PhiC(8,i,j))) + & + ((Hv(I-1,J ) * CS%PhiC(6,i,j)) + (Hv(I,J-1) * CS%PhiC(4,i,j)))) + flux_div(i,j) = Hux(i,j) + Hvy(i,j) + endif + enddo ; enddo + + if (CS%id_duHdx > 0) call post_data(CS%id_duHdx, Hux, CS%diag) + if (CS%id_dvHdy > 0) call post_data(CS%id_dvHdy, Hvy, CS%diag) + if (CS%id_fluxdiv > 0) call post_data(CS%id_fluxdiv, flux_div, CS%diag) + endif + + if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & + CS%id_strainrate_xx > 0 .or. CS%id_strainrate_yy > 0 .or. CS%id_strainrate_xy > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0 .or. & + CS%id_pstrainrate_1 > 0 .or. CS%id_pstrainrate_2 > 0) then + + strain_rate(:,:,:) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + !strain-rates at cell centers + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 3)) then + !strain_rate(:,:,1) = strain_rate_xx(:,:) = ux(:,:) + strain_rate(i,j,1) = (((CS%u_shelf(I-1,J-1) * CS%PhiC(1,i,j)) + (CS%u_shelf(I,J ) * CS%PhiC(7,i,j))) + & + ((CS%u_shelf(I-1,J ) * CS%PhiC(5,i,j)) + (CS%u_shelf(I,J-1) * CS%PhiC(3,i,j)))) + !strain_rate(:,:,2) = strain_rate_yy(:,:) = uy(:,:) + strain_rate(i,j,2) = (((CS%v_shelf(I-1,J-1) * CS%PhiC(2,i,j)) + (CS%v_shelf(I,J ) * CS%PhiC(8,i,j))) + & + ((CS%v_shelf(I-1,J ) * CS%PhiC(6,i,j)) + (CS%v_shelf(I,J-1) * CS%PhiC(4,i,j)))) + !strain_rate(:,:,3) = strain_rate_xy(:,:) = 0.5 * (uy(:,:) + vy(:,:)) + strain_rate(i,j,3) = 0.5 * ((((CS%u_shelf(I-1,J-1) * CS%PhiC(2,i,j)) + (CS%u_shelf(I,J ) * CS%PhiC(8,i,j))) + & + ((CS%u_shelf(I-1,J ) * CS%PhiC(6,i,j)) + (CS%u_shelf(I,J-1) * CS%PhiC(4,i,j))))+ & + (((CS%v_shelf(I-1,J-1) * CS%PhiC(1,i,j)) + (CS%v_shelf(I,J ) * CS%PhiC(7,i,j))) + & + ((CS%v_shelf(I-1,J ) * CS%PhiC(5,i,j)) + (CS%v_shelf(I,J-1) * CS%PhiC(3,i,j))))) + endif + enddo ; enddo + + + if (CS%id_strainrate_xx > 0) call post_data(CS%id_strainrate_xx, strain_rate(:,:,1), CS%diag) + if (CS%id_strainrate_yy > 0) call post_data(CS%id_strainrate_yy, strain_rate(:,:,2), CS%diag) + if (CS%id_strainrate_xy > 0) call post_data(CS%id_strainrate_xy, strain_rate(:,:,3), CS%diag) + + if (CS%id_pstrainrate_1 > 0 .or. CS%id_pstrainrate_2 > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then + p_strain_rate(:,:,:) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + p1 = 0.5*( strain_rate(i,j,1) + strain_rate(i,j,2)) + p2 = sqrt( (( 0.5 * (strain_rate(i,j,1) - strain_rate(i,j,2)) )**2) + (strain_rate(i,j,3)**2) ) + p_strain_rate(i,j,1) = p1+p2 !Max horizontal principal strain-rate + p_strain_rate(i,j,2) = p1-p2 !Min horizontal principal strain-rate + enddo ; enddo + + if (CS%id_pstrainrate_1 > 0) call post_data(CS%id_pstrainrate_1, p_strain_rate(:,:,1), CS%diag) + if (CS%id_pstrainrate_2 > 0) call post_data(CS%id_pstrainrate_2, p_strain_rate(:,:,2), CS%diag) + endif + + if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then + + call ice_visc_diag(CS,G,ice_visc) + + if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0) then + dev_stress(:,:,:)=0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (ISS%h_shelf(i,j)>0) then + dev_stress(i,j,1) = 2*ice_visc(i,j)*strain_rate(i,j,1)/ISS%h_shelf(i,j) !deviatoric stress xx + dev_stress(i,j,2) = 2*ice_visc(i,j)*strain_rate(i,j,2)/ISS%h_shelf(i,j) !deviatoric stress yy + dev_stress(i,j,3) = 2*ice_visc(i,j)*strain_rate(i,j,3)/ISS%h_shelf(i,j) !deviatoric stress xy + endif + enddo; enddo + if (CS%id_devstress_xx > 0) call post_data(CS%id_devstress_xx, dev_stress(:,:,1), CS%diag) + if (CS%id_devstress_yy > 0) call post_data(CS%id_devstress_yy, dev_stress(:,:,2), CS%diag) + if (CS%id_devstress_xy > 0) call post_data(CS%id_devstress_xy, dev_stress(:,:,3), CS%diag) + endif + + if (CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then + p_dev_stress(:,:,:)=0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (ISS%h_shelf(i,j)>0) then + p_dev_stress(i,j,1) = 2*ice_visc(i,j)*p_strain_rate(i,j,1)/ISS%h_shelf(i,j) !max horiz principal dev stress + p_dev_stress(i,j,2) = 2*ice_visc(i,j)*p_strain_rate(i,j,2)/ISS%h_shelf(i,j) !min horiz principal dev stress + endif + enddo; enddo + if (CS%id_pdevstress_1 > 0) call post_data(CS%id_pdevstress_1, p_dev_stress(:,:,1), CS%diag) + if (CS%id_pdevstress_2 > 0) call post_data(CS%id_pdevstress_2, p_dev_stress(:,:,2), CS%diag) + endif + endif + endif +end subroutine IS_dynamics_post_data_2 !> Update depth integrated viscosity, based on horizontal strain rates subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) @@ -2946,7 +3249,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) ! this may be subject to change later... to make it "hybrid" ! real, dimension(SZDIB_(G),SZDJB_(G)) :: eII, ux, uy, vx, vy integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, iq, jq - integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js, i_off, j_off + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js real :: Visc_coef, n_g real :: ux, uy, vx, vy real :: eps_min ! Velocity shears [T-1 ~> s-1] @@ -2959,7 +3262,6 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc is = iscq - 1; js = jscq - 1 - i_off = G%idg_offset ; j_off = G%jdg_offset if (trim(CS%ice_viscosity_compute) == "MODEL") then if (CS%visc_qps==1) then @@ -2978,10 +3280,14 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then if (trim(CS%ice_viscosity_compute) == "CONSTANT") then - CS%ice_visc(i,j,1) = 1e15 * (US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T) * (G%areaT(i,j) * ISS%h_shelf(i,j)) + CS%ice_visc(i,j,1) = 1e15 * (US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T) * & + (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) ! constant viscocity for debugging elseif (trim(CS%ice_viscosity_compute) == "OBS") then - if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j,1) = CS%AGlen_visc(i,j) * (G%areaT(i,j) * ISS%h_shelf(i,j)) + if (CS%AGlen_visc(i,j) >0) then + CS%ice_visc(i,j,1) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & + max(CS%AGlen_visc(i,j) ,CS%min_ice_visc) + endif ! Here CS%Aglen_visc(i,j) is the ice viscosity [Pa s ~> R L2 T-1] computed from obs and read from a file elseif (model_qp1) then !calculate viscosity at 1 cell-centered quadrature point per cell @@ -2989,29 +3295,30 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) Visc_coef = (CS%AGlen_visc(i,j))**(-1./n_g) ! Units of Aglen_visc [Pa-(n_g) s-1] - ux = (u_shlf(I-1,J-1) * CS%PhiC(1,i,j) + & - u_shlf(I,J) * CS%PhiC(7,i,j)) + & - (u_shlf(I-1,J) * CS%PhiC(5,i,j) + & - u_shlf(I,J-1) * CS%PhiC(3,i,j)) - - vx = (v_shlf(I-1,J-1) * CS%PhiC(1,i,j) + & - v_shlf(I,J) * CS%PhiC(7,i,j)) + & - (v_shlf(I-1,J) * CS%PhiC(5,i,j) + & - v_shlf(I,J-1) * CS%PhiC(3,i,j)) - - uy = (u_shlf(I-1,J-1) * CS%PhiC(2,i,j) + & - u_shlf(I,J) * CS%PhiC(8,i,j)) + & - (u_shlf(I-1,J) * CS%PhiC(6,i,j) + & - u_shlf(I,J-1) * CS%PhiC(4,i,j)) - - vy = (v_shlf(I-1,J-1) * CS%PhiC(2,i,j) + & - v_shlf(I,J) * CS%PhiC(8,i,j)) + & - (v_shlf(I-1,J) * CS%PhiC(6,i,j) + & - v_shlf(I,J-1) * CS%PhiC(4,i,j)) - - CS%ice_visc(i,j,1) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & - (US%s_to_T**2 * ((ux**2 + vy**2) + (ux*vy + 0.25*(uy+vx)**2) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & - (US%Pa_to_RL2_T2*US%s_to_T) + ux = ((u_shlf(I-1,J-1) * CS%PhiC(1,i,j)) + & + (u_shlf(I,J) * CS%PhiC(7,i,j))) + & + ((u_shlf(I-1,J) * CS%PhiC(5,i,j)) + & + (u_shlf(I,J-1) * CS%PhiC(3,i,j))) + + vx = ((v_shlf(I-1,J-1) * CS%PhiC(1,i,j)) + & + (v_shlf(I,J) * CS%PhiC(7,i,j))) + & + ((v_shlf(I-1,J) * CS%PhiC(5,i,j)) + & + (v_shlf(I,J-1) * CS%PhiC(3,i,j))) + + uy = ((u_shlf(I-1,J-1) * CS%PhiC(2,i,j)) + & + (u_shlf(I,J) * CS%PhiC(8,i,j))) + & + ((u_shlf(I-1,J) * CS%PhiC(6,i,j)) + & + (u_shlf(I,J-1) * CS%PhiC(4,i,j))) + + vy = ((v_shlf(I-1,J-1) * CS%PhiC(2,i,j)) + & + (v_shlf(I,J) * CS%PhiC(8,i,j))) + & + ((v_shlf(I-1,J) * CS%PhiC(6,i,j)) + & + (v_shlf(I,J-1) * CS%PhiC(4,i,j))) + + CS%ice_visc(i,j,1) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & + max(0.5 * Visc_coef * & + (US%s_to_T**2 * (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & + (US%Pa_to_RL2_T2*US%s_to_T),CS%min_ice_visc) elseif (model_qp4) then !calculate viscosity at 4 quadrature points per cell @@ -3019,29 +3326,30 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) do iq=1,2 ; do jq=1,2 - ux = (u_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j)) + & - (u_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j) + & - u_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j)) - - vx = (v_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j)) + & - (v_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j) + & - v_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j)) - - uy = (u_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j)) + & - (u_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j) + & - u_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j)) - - vy = (v_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j)) + & - (v_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j) + & - v_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j)) - - CS%ice_visc(i,j,2*(jq-1)+iq) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & - (US%s_to_T**2 * ((ux**2 + vy**2) + (ux*vy + 0.25*(uy+vx)**2) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & - (US%Pa_to_RL2_T2*US%s_to_T) + ux = ((u_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j)) + & + (u_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j))) + & + ((u_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j)) + & + (u_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j))) + + vx = ((v_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j)) + & + (v_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j))) + & + ((v_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j)) + & + (v_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j))) + + uy = ((u_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j)) + & + (u_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j))) + & + ((u_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j)) + & + (u_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j))) + + vy = ((v_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j)) + & + (v_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j))) + & + ((v_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j)) + & + (v_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j))) + + CS%ice_visc(i,j,2*(jq-1)+iq) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & + max(0.5 * Visc_coef * & + (US%s_to_T**2 * (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & + (US%Pa_to_RL2_T2*US%s_to_T),CS%min_ice_visc) enddo; enddo endif endif @@ -3099,13 +3407,13 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 - unorm = US%L_T_to_m_s * sqrt( (umid**2 + vmid**2) + (eps_min**2 * (G%dxT(i,j)**2 + G%dyT(i,j)**2)) ) + unorm = US%L_T_to_m_s * sqrt( ((umid**2) + (vmid**2)) + (eps_min**2 * (G%dxT(i,j)**2 + G%dyT(i,j)**2)) ) !Coulomb friction (Schoof 2005, Gagliardini et al 2007) if (CS%CoulombFriction) then !Effective pressure Hf = max((CS%density_ocean_avg/CS%density_ice) * CS%bed_elev(i,j), 0.0) - fN = max(fN_scale*((CS%density_ice * CS%g_Earth) * (ISS%h_shelf(i,j) - Hf)),CS%CF_MinN) + fN = max(fN_scale*((CS%density_ice * CS%g_Earth) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) - Hf)),CS%CF_MinN) fB = alpha * (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%CF_PostPeak/CS%n_basal_fric) CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * & @@ -3116,6 +3424,8 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * (unorm**(CS%n_basal_fric-1))) * & (US%Pa_to_RLZ_T2*US%L_T_to_m_s) endif + + CS%basal_traction(i,j)=max(CS%basal_traction(i,j), CS%min_basal_traction * G%areaT(i,j)) endif enddo enddo @@ -3176,7 +3486,7 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) do j=jsd,jed do i=isd,ied - OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf(i,j) + OD = CS%bed_elev(i,j) - rhoi_rhow * max(h_shelf(i,j),CS%min_h_shelf) if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating CS%OD_av(i,j) = OD @@ -3274,10 +3584,10 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) do qpoint=1,4 - a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) - b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) - c = -X(1)*(1-xquad(qpoint)) - X(2)*xquad(qpoint) + X(3)*(1-xquad(qpoint)) + X(4)*xquad(qpoint) ! d(x)/d(y*) - d = -Y(1)*(1-xquad(qpoint)) - Y(2)*xquad(qpoint) + Y(3)*(1-xquad(qpoint)) + Y(4)*xquad(qpoint) ! d(y)/d(y*) + a = ((-X(1)*(1-yquad(qpoint)))+(X(4)*yquad(qpoint))) + ((X(2)*(1-yquad(qpoint)))-(X(3)*yquad(qpoint))) !d(x)/d(x*) + b = ((-Y(1)*(1-yquad(qpoint)))+(Y(4)*yquad(qpoint))) + ((Y(2)*(1-yquad(qpoint)))-(Y(3)*yquad(qpoint))) !d(y)/d(x*) + c = ((-X(1)*(1-xquad(qpoint)))+(X(4)*xquad(qpoint))) + ((-X(2)*xquad(qpoint))+(X(3)*(1-xquad(qpoint))))!d(x)/d(y*) + d = ((-Y(1)*(1-xquad(qpoint)))+(Y(4)*xquad(qpoint))) + ((-Y(2)*xquad(qpoint))+(Y(3)*(1-xquad(qpoint))))!d(y)/d(y*) do node=1,4 @@ -3295,8 +3605,8 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) xexp = xquad(qpoint) endif - Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) - Phi(2*node,qpoint) = (-c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) + Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / ((a*d)-(b*c)) + Phi(2*node,qpoint) = (-c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / ((a*d)-(b*c)) enddo enddo @@ -3336,12 +3646,12 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) do qpoint=1,4 if (J>1) then - a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) + a = (G%dxCv(i,J-1) * (1-yquad(qpoint))) + (G%dxCv(i,J) * yquad(qpoint)) ! d(x)/d(x*) else a = G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) endif if (I>1) then - d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) + d = (G%dyCu(I-1,j) * (1-xquad(qpoint))) + (G%dyCu(I,j) * xquad(qpoint)) ! d(y)/d(y*) else d = G%dyCu(I,j) !* xquad(qpoint) endif @@ -3622,8 +3932,8 @@ end subroutine update_velocity_masks !> Interpolate the ice shelf thickness from tracer point to nodal points, !! subject to a mask. -subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) - type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. +subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node, min_h_shelf) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: h_shelf !< The ice shelf thickness at tracer points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & @@ -3632,6 +3942,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. + real, intent(in) :: min_h_shelf !< The minimum ice thickness used during ice dynamics [L ~> m]. integer :: i, j, isc, iec, jsc, jec, num_h, k, l, ic, jc real :: h_arr(2,2) @@ -3648,7 +3959,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) num_h = 0 do l=1,2; jc=j-1+l; do k=1,2; ic=i-1+k if (hmask(ic,jc) == 1.0 .or. hmask(ic,jc) == 3.0) then - h_arr(k,l)=h_shelf(ic,jc) + h_arr(k,l)=max(h_shelf(ic,jc),min_h_shelf) num_h = num_h + 1 else h_arr(k,l)=0.0 @@ -3772,7 +4083,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) call pass_var(CS%tmask, G%domain, complete=.true.) if (CS%debug) then - call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3, scale=US%C_to_degC) + call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3, unscale=US%C_to_degC) endif end subroutine ice_shelf_temp @@ -3857,8 +4168,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j) * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j)) * & + (stencil(-1) - (phi * (stencil(-1)-stencil(0))/2))) else ! h(i-1) is valid ! (o.w. flux would most likely be out of cell) @@ -3871,8 +4182,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + flux_diff = flux_diff - ((ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(-1))/2))) else flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * stencil(0) @@ -3902,8 +4213,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j)) * & + (stencil(1) - (phi * (stencil(1)-stencil(0))/2))) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) @@ -3918,8 +4229,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) + flux_diff = flux_diff - ((ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(1))/2))) else ! h(i+1) is valid (o.w. flux would most likely be out of cell) but h(i+2) is not @@ -4023,8 +4334,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * & + (stencil(-1) - (phi * (stencil(-1)-stencil(0))/2))) else ! h(j-1) is valid ! (o.w. flux would most likely be out of cell) @@ -4036,8 +4347,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + flux_diff = flux_diff - ((ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(-1))/2))) else flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * stencil(0) endif @@ -4063,8 +4374,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j)) * & + (stencil(1) - (phi * (stencil(1)-stencil(0))/2))) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not @@ -4075,8 +4386,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) + flux_diff = flux_diff - ((ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(1))/2))) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index e6be780073..d789c08bd4 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -46,9 +46,13 @@ module MOM_ice_shelf_state tflux_shelf => NULL(), & !< The downward diffusive heat flux in the ice !! shelf at the ice-ocean interface [Q R Z T-1 ~> W m-2]. - tfreeze => NULL() !< The freezing point potential temperature + tfreeze => NULL(), & !< The freezing point potential temperature !! at the ice-ocean interface [C ~> degC]. + !only active when calve_ice_shelf_bergs=true: + calving => NULL(), & !< The mass flux per unit area of the ice shelf to convert to + !! bergs [R Z T-1 ~> kg m-2 s-1]. + calving_hflx => NULL() !< Calving heat flux [Q R Z T-1 ~> W m-2]. end type ice_shelf_state contains @@ -80,6 +84,8 @@ subroutine ice_shelf_state_init(ISS, G) allocate(ISS%tflux_shelf(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%tfreeze(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%calving(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%calving_hflx(isd:ied,jsd:jed), source=0.0 ) end subroutine ice_shelf_state_init @@ -94,6 +100,8 @@ subroutine ice_shelf_state_end(ISS) deallocate(ISS%tflux_ocn, ISS%water_flux, ISS%salt_flux, ISS%tflux_shelf) deallocate(ISS%tfreeze) + deallocate(ISS%calving, ISS%calving_hflx) + deallocate(ISS) end subroutine ice_shelf_state_end diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index bb7832525f..9acf693f5f 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -600,8 +600,8 @@ subroutine write_vertgrid_file(GV, US, param_file, directory) call create_MOM_file(IO_handle, trim(filepath), vars, 2, fields, & SINGLE_FILE, GV=GV) - call MOM_write_field(IO_handle, fields(1), GV%Rlay, scale=US%R_to_kg_m3) - call MOM_write_field(IO_handle, fields(2), GV%g_prime, scale=US%L_T_to_m_s**2*US%m_to_Z) + call MOM_write_field(IO_handle, fields(1), GV%Rlay, unscale=US%R_to_kg_m3) + call MOM_write_field(IO_handle, fields(2), GV%g_prime, unscale=US%L_T_to_m_s**2*US%m_to_Z) call IO_handle%close() diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 8b172eacb9..f54eb8a638 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -102,7 +102,7 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) call open_boundary_impose_land_mask(OBC, G, G%areaCu, G%areaCv, US) if (debug) then - call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1, unscale=US%Z_to_m) call hchksum(G%mask2dT, 'MOM_initialize_fixed: mask2dT ', G%HI) call uvchksum('MOM_initialize_fixed: mask2dC[uv]', G%mask2dCu, & G%mask2dCv, G%HI) @@ -146,6 +146,7 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) endif ! Read sub-grid scale topography parameters at velocity points used for porous barrier calculation + ! TODO: The following routine call may eventually be merged as one of the CHANNEL_CONFIG options call get_param(PF, mdl, "SUBGRID_TOPO_AT_VEL", read_porous_file, & "If true, use variables from TOPO_AT_VEL_FILE as parameters for porous barrier.", & default=.False.) @@ -163,10 +164,10 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) enddo ; enddo if (debug) then - call qchksum(G%CoriolisBu, "MOM_initialize_fixed: f ", G%HI, scale=US%s_to_T) - call qchksum(G%Coriolis2Bu, "MOM_initialize_fixed: f2 ", G%HI, scale=US%s_to_T**2) - call hchksum(G%dF_dx, "MOM_initialize_fixed: dF_dx ", G%HI, scale=US%m_to_L*US%s_to_T) - call hchksum(G%dF_dy, "MOM_initialize_fixed: dF_dy ", G%HI, scale=US%m_to_L*US%s_to_T) + call qchksum(G%CoriolisBu, "MOM_initialize_fixed: f ", G%HI, unscale=US%s_to_T) + call qchksum(G%Coriolis2Bu, "MOM_initialize_fixed: f2 ", G%HI, unscale=US%s_to_T**2) + call hchksum(G%dF_dx, "MOM_initialize_fixed: dF_dx ", G%HI, unscale=US%m_to_L*US%s_to_T) + call hchksum(G%dF_dy, "MOM_initialize_fixed: dF_dy ", G%HI, unscale=US%m_to_L*US%s_to_T) endif call initialize_grid_rotation_angle(G, PF) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 8bea8fe6e9..ef78a896c3 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -128,28 +128,28 @@ subroutine grid_metrics_chksum(parent, G, US) halo = min(G%ied-G%iec, G%jed-G%jec, 1) call hchksum_pair(trim(parent)//': d[xy]T', G%dxT, G%dyT, G%HI, & - haloshift=halo, scale=US%L_to_m, scalar_pair=.true.) + haloshift=halo, unscale=US%L_to_m, scalar_pair=.true.) - call uvchksum(trim(parent)//': dxC[uv]', G%dxCu, G%dyCv, G%HI, haloshift=halo, scale=US%L_to_m) + call uvchksum(trim(parent)//': dxC[uv]', G%dxCu, G%dyCv, G%HI, haloshift=halo, unscale=US%L_to_m) - call uvchksum(trim(parent)//': dxC[uv]', G%dyCu, G%dxCv, G%HI, haloshift=halo, scale=US%L_to_m) + call uvchksum(trim(parent)//': dxC[uv]', G%dyCu, G%dxCv, G%HI, haloshift=halo, unscale=US%L_to_m) - call Bchksum_pair(trim(parent)//': dxB[uv]', G%dxBu, G%dyBu, G%HI, haloshift=halo, scale=US%L_to_m) + call Bchksum_pair(trim(parent)//': dxB[uv]', G%dxBu, G%dyBu, G%HI, haloshift=halo, unscale=US%L_to_m) call hchksum_pair(trim(parent)//': Id[xy]T', G%IdxT, G%IdyT, G%HI, & - haloshift=halo, scale=US%m_to_L, scalar_pair=.true.) + haloshift=halo, unscale=US%m_to_L, scalar_pair=.true.) - call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdxCu, G%IdyCv, G%HI, haloshift=halo, scale=US%m_to_L) + call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdxCu, G%IdyCv, G%HI, haloshift=halo, unscale=US%m_to_L) - call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdyCu, G%IdxCv, G%HI, haloshift=halo, scale=US%m_to_L) + call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdyCu, G%IdxCv, G%HI, haloshift=halo, unscale=US%m_to_L) - call Bchksum_pair(trim(parent)//': Id[xy]B[uv]', G%IdxBu, G%IdyBu, G%HI, haloshift=halo, scale=US%m_to_L) + call Bchksum_pair(trim(parent)//': Id[xy]B[uv]', G%IdxBu, G%IdyBu, G%HI, haloshift=halo, unscale=US%m_to_L) - call hchksum(G%areaT, trim(parent)//': areaT',G%HI, haloshift=halo, scale=US%L_to_m**2) - call Bchksum(G%areaBu, trim(parent)//': areaBu',G%HI, haloshift=halo, scale=US%L_to_m**2) + call hchksum(G%areaT, trim(parent)//': areaT',G%HI, haloshift=halo, unscale=US%L_to_m**2) + call Bchksum(G%areaBu, trim(parent)//': areaBu',G%HI, haloshift=halo, unscale=US%L_to_m**2) - call hchksum(G%IareaT, trim(parent)//': IareaT',G%HI, haloshift=halo, scale=US%m_to_L**2) - call Bchksum(G%IareaBu, trim(parent)//': IareaBu',G%HI, haloshift=halo, scale=US%m_to_L**2) + call hchksum(G%IareaT, trim(parent)//': IareaT',G%HI, haloshift=halo, unscale=US%m_to_L**2) + call Bchksum(G%IareaBu, trim(parent)//': IareaBu',G%HI, haloshift=halo, unscale=US%m_to_L**2) call hchksum(G%geoLonT,trim(parent)//': geoLonT',G%HI, haloshift=halo) call hchksum(G%geoLatT,trim(parent)//': geoLatT',G%HI, haloshift=halo) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 821232b80d..edf08da3aa 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1424,30 +1424,30 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) call MOM_write_field(IO_handle, fields(3), G%Domain, G%geoLatT) call MOM_write_field(IO_handle, fields(4), G%Domain, G%geoLonT) - call MOM_write_field(IO_handle, fields(5), G%Domain, G%bathyT, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(6), G%Domain, G%CoriolisBu, scale=US%s_to_T) - - call MOM_write_field(IO_handle, fields(7), G%Domain, G%dxCv, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(8), G%Domain, G%dyCu, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(9), G%Domain, G%dxCu, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(10), G%Domain, G%dyCv, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(11), G%Domain, G%dxT, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(12), G%Domain, G%dyT, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(13), G%Domain, G%dxBu, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(14), G%Domain, G%dyBu, scale=US%L_to_m) - - call MOM_write_field(IO_handle, fields(15), G%Domain, G%areaT, scale=US%L_to_m**2) - call MOM_write_field(IO_handle, fields(16), G%Domain, G%areaBu, scale=US%L_to_m**2) - - call MOM_write_field(IO_handle, fields(17), G%Domain, G%dx_Cv, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(18), G%Domain, G%dy_Cu, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(5), G%Domain, G%bathyT, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(6), G%Domain, G%CoriolisBu, unscale=US%s_to_T) + + call MOM_write_field(IO_handle, fields(7), G%Domain, G%dxCv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(8), G%Domain, G%dyCu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(9), G%Domain, G%dxCu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(10), G%Domain, G%dyCv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(11), G%Domain, G%dxT, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(12), G%Domain, G%dyT, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(13), G%Domain, G%dxBu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(14), G%Domain, G%dyBu, unscale=US%L_to_m) + + call MOM_write_field(IO_handle, fields(15), G%Domain, G%areaT, unscale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(16), G%Domain, G%areaBu, unscale=US%L_to_m**2) + + call MOM_write_field(IO_handle, fields(17), G%Domain, G%dx_Cv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(18), G%Domain, G%dy_Cu, unscale=US%L_to_m) call MOM_write_field(IO_handle, fields(19), G%Domain, G%mask2dT) if (G%bathymetry_at_vel) then - call MOM_write_field(IO_handle, fields(20), G%Domain, G%Dblock_u, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(21), G%Domain, G%Dopen_u, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(22), G%Domain, G%Dblock_v, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(23), G%Domain, G%Dopen_v, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(20), G%Domain, G%Dblock_u, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(21), G%Domain, G%Dopen_u, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(22), G%Domain, G%Dblock_v, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(23), G%Domain, G%Dopen_v, unscale=US%Z_to_m) endif call IO_handle%close() diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 8841ca90e6..769d60d51d 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -92,7 +92,7 @@ module MOM_state_initialization use MOM_ALE, only : ALE_remap_scalar, ALE_regrid_accelerated, TS_PLM_edge_values use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution use MOM_regridding, only : regridding_main, regridding_preadjust_reqs, convective_adjustment -use MOM_regridding, only : set_dz_neglect +use MOM_regridding, only : set_dz_neglect, set_h_neglect use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer, homogenize_field use MOM_oda_incupd, only: oda_incupd_CS, initialize_oda_incupd_fixed, initialize_oda_incupd @@ -450,7 +450,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "DEPRESS_INITIAL_SURFACE and TRIM_IC_FOR_P_SURF are exclusive and cannot both be True") if (new_sim .and. debug .and. (depress_sfc .or. trim_ic_for_p_surf)) & - call hchksum(h, "Pre-depress: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h, "Pre-depress: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) ! Remove the mass that would be displaced by an ice shelf or inverse barometer. if (depress_sfc) then @@ -479,7 +479,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & units="s", scale=US%s_to_T, fail_if_missing=.true.) if (new_sim .and. debug) & - call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & dt=dt, initial=.true.) endif @@ -517,7 +517,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if (new_sim) call pass_vector(u, v, G%Domain) if (debug .and. new_sim) then - call uvchksum("MOM_initialize_state [uv]", u, v, G%HI, haloshift=1, scale=US%L_T_to_m_s) + call uvchksum("MOM_initialize_state [uv]", u, v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) endif ! This is the end of the block of code that might have initialized fields @@ -552,14 +552,14 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call pass_var(h, G%Domain) if (debug) then - call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) - if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1, scale=US%C_to_degC) - if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1, scale=US%S_to_ppt) + call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) + if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1, unscale=US%C_to_degC) + if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1, unscale=US%S_to_ppt) if ( use_temperature .and. debug_layers) then ; do k=1,nz write(mesg,'("MOM_IS: T[",I2,"]")') k - call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1, scale=US%C_to_degC) + call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1, unscale=US%C_to_degC) write(mesg,'("MOM_IS: S[",I2,"]")') k - call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1, scale=US%S_to_ppt) + call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1, unscale=US%S_to_ppt) enddo ; endif endif @@ -1189,7 +1189,13 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) if (use_remapping) then allocate(remap_CS) - call initialize_remapping(remap_CS, 'PLM', boundary_extrapolation=.true.) + if (remap_answer_date < 20190101) then + call initialize_remapping(remap_CS, 'PLM', boundary_extrapolation=.true., & + h_neglect=1.0e-30*GV%m_to_H, h_neglect_edge=1.0e-10*GV%m_to_H) + else + call initialize_remapping(remap_CS, 'PLM', boundary_extrapolation=.true., & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) + endif endif ! Find edge values of T and S used in reconstructions @@ -1204,10 +1210,9 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) endif do j=G%jsc,G%jec ; do i=G%isc,G%iec - call cut_off_column_top(GV%ke, tv, GV, US, GV%g_Earth, G%bathyT(i,j)+G%Z_ref, & - min_thickness, tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), & - tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), p_surf(i,j), h(i,j,:), remap_CS, & - z_tol=z_tolerance, remap_answer_date=remap_answer_date) + call cut_off_column_top(GV%ke, tv, GV, US, GV%g_Earth, G%bathyT(i,j)+G%Z_ref, min_thickness, & + tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), & + p_surf(i,j), h(i,j,:), remap_CS, z_tol=z_tolerance) enddo ; enddo end subroutine trim_for_ice @@ -1298,7 +1303,7 @@ end subroutine calc_sfc_displacement !> Adjust the layer thicknesses by removing the top of the water column above the !! depth where the hydrostatic pressure matches p_surf subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, T_t, T_b, & - S, S_t, S_b, p_surf, h, remap_CS, z_tol, remap_answer_date) + S, S_t, S_b, p_surf, h, remap_CS, z_tol) integer, intent(in) :: nk !< Number of layers type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1318,10 +1323,6 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, !! if associated real, intent(in) :: z_tol !< The tolerance with which to find the depth !! matching the specified pressure [Z ~> m]. - integer, optional, intent(in) :: remap_answer_date !< The vintage of the order of arithmetic and - !! expressions to use for remapping. Values below 20190101 - !! recover the remapping answers from 2018, while higher - !! values use more robust forms of the same remapping expressions. ! Local variables real, dimension(nk+1) :: e ! Top and bottom edge positions for reconstructions [Z ~> m] @@ -1332,11 +1333,8 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, real :: z_out, e_top ! Interface height positions [Z ~> m] real :: min_dz ! The minimum thickness in depth units [Z ~> m] real :: dh_surf_rem ! The remaining thickness to remove in non-Bousinesq mode [H ~> kg m-2] - logical :: answers_2018 integer :: k - answers_2018 = .true. ; if (present(remap_answer_date)) answers_2018 = (remap_answer_date < 20190101) - ! Keep a copy of the initial thicknesses in reverse order to use in remapping do k=1,nk ; h0(k) = h(nk+1-k) ; enddo @@ -1407,13 +1405,8 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, T0(k) = T(nk+1-k) h1(k) = h(nk+1-k) enddo - if (answers_2018) then - call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1, 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) - call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1, 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) - else - call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1, GV%H_subroundoff, GV%H_subroundoff) - call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1, GV%H_subroundoff, GV%H_subroundoff) - endif + call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1) + call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1) do k=1,nk S(k) = S1(nk+1-k) T(k) = T1(nk+1-k) @@ -2045,7 +2038,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t ! This call to set_up_sponge_ML_density registers the target values of the ! mixed layer density, which is used in determining which layers can be ! inflated without causing static instabilities. - do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo + do i=is,ie ; pres(i) = tv%P_Ref ; enddo EOSdom(:) = EOS_domain(G%HI) call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain, scale=US%degC_to_C) @@ -2310,7 +2303,7 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p call MOM_error(FATAL, " initialize_oda_incupd_uv: Unable to open "//trim(filename)) allocate(tmp_u(G%IsdB:G%IedB,jsd:jed,nz_data), source=0.0) allocate(tmp_v(isd:ied,G%JsdB:G%JedB,nz_data), source=0.0) - call MOM_read_vector(filename, uinc_var, vinc_var, tmp_u, tmp_v, G%Domain,scale=US%m_s_to_L_T) + call MOM_read_vector(filename, uinc_var, vinc_var, tmp_u, tmp_v, G%Domain, scale=US%m_s_to_L_T) call set_up_oda_incupd_vel_field(tmp_u, tmp_v, G, GV, oda_incupd_CSp) deallocate(tmp_u, tmp_v) endif @@ -2504,6 +2497,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just character(len=64) :: remappingScheme real :: tempAvg ! Spatially averaged temperatures on a layer [C ~> degC] real :: saltAvg ! Spatially averaged salinities on a layer [S ~> ppt] + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm (only used if useALEremapping) logical :: do_conv_adj, ignore integer :: nPoints integer :: id_clock_routine, id_clock_ALE @@ -2583,6 +2577,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + call get_param(PF, mdl, "Z_INIT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for initialization. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & @@ -2753,7 +2751,14 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! Build the target grid (and set the model thickness to it) call ALE_initRegridding( GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS - call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) + if (remap_general) then + dz_neglect = set_h_neglect(GV, remap_answer_date, dz_neglect_edge) + else + dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) + endif + call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date, & + h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) ! Now remap from source grid to target grid, first setting reconstruction parameters if (remap_general) then @@ -2768,9 +2773,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just deallocate( dz_interface ) call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & - old_remap=remap_old_alg, answer_date=remap_answer_date ) + old_remap=remap_old_alg ) call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, & - old_remap=remap_old_alg, answer_date=remap_answer_date ) + old_remap=remap_old_alg ) else ! This is the old way of initializing to z* coordinates only allocate( hTarget(nz) ) @@ -2793,11 +2798,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) call ALE_remap_scalar(remapCS, G, GV, nkd, dz1, tmpT1dIn, dz, tv%T, all_cells=remap_full_column, & - old_remap=remap_old_alg, answer_date=remap_answer_date, & - H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + old_remap=remap_old_alg) call ALE_remap_scalar(remapCS, G, GV, nkd, dz1, tmpS1dIn, dz, tv%S, all_cells=remap_full_column, & - old_remap=remap_old_alg, answer_date=remap_answer_date, & - H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + old_remap=remap_old_alg) if (GV%Boussinesq .or. GV%semi_Boussinesq) then ! This is a simple conversion of the target grid to thickness units that is not @@ -3100,9 +3103,17 @@ subroutine MOM_state_init_tests(G, GV, US, tv) write(0,*) ' ==================================================================== ' write(0,*) '' write(0,*) GV%H_to_m*h(:) + + ! For consistency with the usual call, add the following: + ! if (use_remapping) then + ! allocate(remap_CS) + ! call initialize_remapping(remap_CS, 'PLM', boundary_extrapolation=.true., & + ! h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) + ! endif call cut_off_column_top(nk, tv, GV, US, GV%g_Earth, -e(nk+1), GV%Angstrom_H, & T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS, z_tol=z_tol) write(0,*) GV%H_to_m*h(:) + if (associated(remap_CS)) deallocate(remap_CS) end subroutine MOM_state_init_tests diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index cac8a5cd6c..6e3da385ce 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -13,7 +13,7 @@ module MOM_tracer_initialization_from_Z use MOM_grid, only : ocean_grid_type use MOM_horizontal_regridding, only : myStats, horiz_interp_and_extrap_tracer use MOM_interface_heights, only : dz_to_thickness_simple -use MOM_regridding, only : set_dz_neglect +use MOM_regridding, only : set_dz_neglect, set_h_neglect use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -93,9 +93,10 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ real :: missing_value ! A value indicating that there is no valid input data at this point [CU ~> conc] real :: dz_neglect ! A negligibly small vertical layer extent used in - ! remapping cell reconstructions [Z ~> m] + ! remapping cell reconstructions [Z ~> m] or [H ~> m or kg m-2] real :: dz_neglect_edge ! A negligibly small vertical layer extent used in - ! remapping edge value calculations [Z ~> m] + ! remapping edge value calculations [Z ~> m] or [H ~> m or kg m-2] + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: nPoints ! The number of valid input data points in a column integer :: id_clock_routine, id_clock_ALE integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. @@ -116,7 +117,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + call callTree_enter(trim(mdl)//"(), MOM_tracer_initialization_from_Z.F90") call get_param(PF, mdl, "Z_INIT_HOMOGENIZE", homog, & "If True, then horizontally homogenize the interpolated "//& @@ -137,6 +138,10 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) + call get_param(PF, mdl, "Z_INIT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for initialization. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & @@ -173,8 +178,15 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ allocate( h1(kd) ) allocate( dzSrc(isd:ied,jsd:jed,kd) ) allocate( hSrc(isd:ied,jsd:jed,kd) ) - ! Set parameters for reconstructions - call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) + ! Set parameters for reconstructions in the right units + if (h_is_in_Z_units) then + dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) + else + dz_neglect = set_h_neglect(GV, remap_answer_date, dz_neglect_edge) + endif + call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date, & + H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge ) ! Next we initialize the regridding package so that it knows about the target grid do j = js, je ; do i = is, ie @@ -200,18 +212,15 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ enddo ; enddo if (h_is_in_Z_units) then - ! Because h is in units of [Z ~> m], dzSrc is already in the right units, but we need to - ! specify negligible thickness values with the right units. - dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) - call ALE_remap_scalar(remapCS, G, GV, kd, dzSrc, tr_z, h, tr, all_cells=.false., answer_date=remap_answer_date, & - H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + ! Because h is in units of [Z ~> m], dzSrc is already in the right units. + call ALE_remap_scalar(remapCS, G, GV, kd, dzSrc, tr_z, h, tr, all_cells=.false.) else ! Equation of state data is not available, so a simpler rescaling will have to suffice, ! but it might be problematic in non-Boussinesq mode. GV_loc = GV ; GV_loc%ke = kd call dz_to_thickness_simple(dzSrc, hSrc, G, GV_loc, US) - call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false., answer_date=remap_answer_date ) + call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false.) endif deallocate( hSrc ) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 6e24b9faee..d620962222 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -55,7 +55,7 @@ module MOM_oda_driver_mod use MOM_domains, only : MOM_domains_init, MOM_domain_type, clone_MOM_domain use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_regridding, only : regridding_CS, initialize_regridding -use MOM_regridding, only : regridding_main, set_regrid_params +use MOM_regridding, only : regridding_main, set_regrid_params, set_h_neglect use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit @@ -119,7 +119,7 @@ module MOM_oda_driver_mod logical :: use_basin_mask !< If true, use a basin file to delineate weakly coupled ocean basins logical :: do_bias_adjustment !< If true, use spatio-temporally varying climatological tendency !! adjustment for Temperature and Salinity - real :: bias_adjustment_multiplier !< A scaling for the bias adjustment + real :: bias_adjustment_multiplier !< A scaling for the bias adjustment [nondim] integer :: assim_method !< Method: NO_ASSIM,EAKF_ASSIM or OI_ASSIM integer :: ensemble_size !< Size of the ensemble integer :: ensemble_id = 0 !< id of the current ensemble member @@ -183,6 +183,8 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) character(len=80) :: remap_scheme character(len=80) :: bias_correction_file, inc_file integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) @@ -243,7 +245,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call get_param(PF, mdl, "INPUTDIR", inputdir) call get_param(PF, mdl, "ODA_REMAPPING_SCHEME", remap_scheme, & "This sets the reconstruction scheme used "//& - "for vertical remapping for all variables. "//& + "for vertical remapping for all ODA variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default="PPM_H4") call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & @@ -320,8 +322,17 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call get_param(PF, 'oda_driver', "REGRIDDING_COORDINATE_MODE", coord_mode, & "Coordinate mode for vertical regridding.", & default="ZSTAR", fail_if_missing=.false.) + call get_param(PF, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) + call get_param(PF, mdl, "ODA_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ODA. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') - call initialize_remapping(CS%remapCS,remap_scheme) + + h_neglect = set_h_neglect(GV, CS%answer_date, h_neglect_edge) + call initialize_remapping(CS%remapCS, remap_scheme, om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) call set_regrid_params(CS%regridCS, min_thickness=0.) isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed @@ -412,7 +423,6 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) real, dimension(SZI_(G),SZJ_(G),CS%nk) :: S ! Salinity on the analysis grid [S ~> ppt] integer :: i, j, m integer :: isc, iec, jsc, jec - real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] ! return if not time for analysis if (Time < CS%Time) return @@ -424,14 +434,6 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) call set_PElist(CS%filter_pelist) !call MOM_mesg('Setting prior') - if (CS%answer_date >= 20190101) 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 - endif - ! computational domain for the analysis grid isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec ! array extents for the ensemble member @@ -440,9 +442,9 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) ! remap temperature and salinity from the ensemble member to the analysis grid do j=G%jsc,G%jec ; do i=G%isc,G%iec call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%T(i,j,:), & - CS%nk, CS%h(i,j,:), T(i,j,:), h_neglect, h_neglect_edge) + CS%nk, CS%h(i,j,:), T(i,j,:)) call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & - CS%nk, CS%h(i,j,:), S(i,j,:), h_neglect, h_neglect_edge) + CS%nk, CS%h(i,j,:), S(i,j,:)) enddo ; enddo ! cast ensemble members to the analysis domain do m=1,CS%ensemble_size @@ -680,7 +682,6 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) !! DA [C T-1 ~> degC s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: S_tend !< The salinity tendency adjustment from DA !! [S T-1 ~> ppt s-1] - real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (.not. associated(CS)) return if (CS%assim_method == NO_ASSIM .and. (.not. CS%do_bias_adjustment)) return @@ -697,20 +698,12 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) S_tend = S_tend + CS%S_bc_tend endif - if (CS%answer_date >= 20190101) 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 - endif - isc=G%isc; iec=G%iec; jsc=G%jsc; jec=G%jec do j=jsc,jec; do i=isc,iec call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), T_tend(i,j,:), & - G%ke, h(i,j,:), T_tend_inc(i,j,:), h_neglect, h_neglect_edge) + G%ke, h(i,j,:), T_tend_inc(i,j,:)) call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), S_tend(i,j,:), & - G%ke, h(i,j,:), S_tend_inc(i,j,:), h_neglect, h_neglect_edge) + G%ke, h(i,j,:), S_tend_inc(i,j,:)) enddo; enddo @@ -734,13 +727,17 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) end subroutine apply_oda_tracer_increments +!> Set up the grid of thicknesses at tracer points throughout the global domain subroutine set_up_global_tgrid(T_grid, CS, G) type(grid_type), pointer :: T_grid !< global tracer grid type(ODA_CS), pointer, intent(in) :: CS !< A pointer to DA control structure. type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model ! local variables - real, dimension(:,:), allocatable :: global2D, global2D_old + real, dimension(:,:), allocatable :: & + global2D, & ! A layer thickness in the entire global domain [H ~> m or kg m-2] + global2D_old ! The thickness of the layer above the one in global2D in the entire + ! global domain [H ~> m or kg m-2] integer :: i, j, k ! get global grid information from ocean_model @@ -769,6 +766,8 @@ subroutine set_up_global_tgrid(T_grid, CS, G) do k = 1, CS%nk call global_field(G%Domain%mpp_domain, CS%h(:,:,k), global2D) do i=1,CS%ni ; do j=1,CS%nj + ! ###Does the next line need to be revised? Perhaps it should be + ! if ( global2D(i,j) > 1.0*GV%H_to_m ) then if ( global2D(i,j) > 1 ) then T_grid%mask(i,j,k) = 1.0 endif diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index be57bbe748..f174bf14ad 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -25,6 +25,7 @@ module MOM_oda_incupd use MOM_grid, only : ocean_grid_type use MOM_io, only : vardesc, var_desc use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping +use MOM_remapping, only : remappingSchemesDoc use MOM_restart, only : register_restart_field, register_restart_pair, MOM_restart_CS use MOM_restart, only : restart_init, save_restart, query_initialized use MOM_spatial_means, only : global_i_mean @@ -52,9 +53,11 @@ module MOM_oda_incupd type :: p3d integer :: id !< id for FMS external time interpolator integer :: nz_data !< The number of vertical levels in the input field. - real, dimension(:,:,:), pointer :: mask_in => NULL() !< pointer to the data mask. - real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data. - real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid. + real, dimension(:,:,:), pointer :: mask_in => NULL() !< pointer to the data mask (perhaps unused) [nondim] + real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data, in units that depend + !! on the field it refers to [various]. + real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid (perhaps unused) + !! in [H ~> m or kg m-2] end type p3d !> oda incupd control structure @@ -67,11 +70,12 @@ module MOM_oda_incupd type(p3d) :: Inc(MAX_FIELDS_) !< The increments to be applied to the field type(p3d) :: Inc_u !< The increments to be applied to the u-velocities, with data in [L T-1 ~> m s-1] type(p3d) :: Inc_v !< The increments to be applied to the v-velocities, with data in [L T-1 ~> m s-1] - type(p3d) :: Ref_h !< Vertical grid on which the increments are provided + type(p3d) :: Ref_h !< Vertical grid on which the increments are provided, with data in [H ~> m or kg m-2] integer :: nstep_incupd !< number of time step for full update - real :: ncount = 0.0 !< increment time step counter + real :: ncount = 0.0 !< increment time step counter [nondim]. This could be an integer + !! but a real variable works better with the existing restarts. type(remapping_cs) :: remap_cs !< Remapping parameters and work arrays logical :: incupdDataOngrid !< True if the incupd data are on the model horizontal grid logical :: uv_inc !< use u and v increments @@ -136,9 +140,13 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: reset_ncount integer :: i, j, k - real :: nhours_incupd, dt, dt_therm + real :: incupd_timescale ! The amount of timer over which to apply the full update [T ~> s] + real :: dt, dt_therm ! Model timesteps [T ~> s] character(len=256) :: mesg character(len=64) :: remapScheme + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + if (.not.associated(CS)) then call MOM_error(WARNING, "initialize_oda_incupd called without an associated "// & "control structure.") @@ -153,9 +161,9 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re if (.not.use_oda_incupd) return - call get_param(param_file, mdl, "ODA_INCUPD_NHOURS", nhours_incupd, & + call get_param(param_file, mdl, "ODA_INCUPD_NHOURS", incupd_timescale, & "Number of hours for full update (0=direct insertion).", & - default=3.0,units="h", scale=US%s_to_T) + default=3.0, units="h", scale=3600.0*US%s_to_T) call get_param(param_file, mdl, "ODA_INCUPD_RESET_NCOUNT", reset_ncount, & "If True, reinitialize number of updates already done, ncount.", & default=.true.) @@ -177,20 +185,29 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re "use U,V increments.", & default=.true.) call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & - "This sets the reconstruction scheme used "//& - " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) + call get_param(param_file, mdl, "ODA_REMAPPING_SCHEME", remapScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all ODA variables. "//& + "It can be one of the following schemes: "//& + trim(remappingSchemesDoc), default=remapScheme) + !The default should be REMAP_BOUNDARY_EXTRAP call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & - "When defined, a proper high-order reconstruction "//& - "scheme is used within boundary cells rather "//& - "than PCM. E.g., if PPM is used for remapping, a "//& - "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "ODA_BOUNDARY_EXTRAP", bndExtrapolation, & + "If true, values at the interfaces of boundary cells are "//& + "extrapolated instead of piecewise constant", default=bndExtrapolation) call get_param(param_file, mdl, "ODA_INCUPD_DATA_ONGRID", CS%incupdDataOngrid, & "When defined, the incoming oda_incupd data are "//& "assumed to be on the model horizontal grid " , & default=.true.) + call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) + call get_param(param_file, mdl, "ODA_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ODA. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) CS%nz = GV%ke @@ -199,10 +216,10 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re 'The oda_incupd code only applies ODA increments on the same horizontal grid. ') ! get number of timestep for full update - if (nhours_incupd == 0) then + if (incupd_timescale == 0) then CS%nstep_incupd = 1 !! direct insertion else - CS%nstep_incupd = floor( nhours_incupd * 3600. / dt_therm + 0.001 ) - 1 + CS%nstep_incupd = floor( incupd_timescale / dt_therm + 0.001 ) - 1 endif write(mesg,'(i12)') CS%nstep_incupd if (is_root_pe()) & @@ -231,8 +248,15 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re ! Call the constructor for remapping control structure !### Revisit this hard-coded answer_date. + 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%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + endif + call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & - answer_date=20190101) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=20190101, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) end subroutine initialize_oda_incupd @@ -243,8 +267,9 @@ subroutine set_up_oda_incupd_field(sp_val, G, GV, CS) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(oda_incupd_CS), pointer :: CS !< oda_incupd control structure (in/out). real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & - intent(in) :: sp_val !< increment field, it can have an - !! arbitrary number of layers. + intent(in) :: sp_val !< increment field, it can have an arbitrary number + !! of layers, in various units depending on the + !! field it refers to [various]. integer :: i, j, k character(len=256) :: mesg ! String for error messages @@ -338,7 +363,6 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) integer :: i, j, k, is, ie, js, je, nz, nz_data integer :: isB, ieB, jsB, jeB - real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] real :: sum_h1, sum_h2 ! vertical sums of h's [H ~> m or kg m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -350,13 +374,6 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) if (CS%ncount /= 0.0) call MOM_error(FATAL,'calc_oda_increments: '// & 'CS%ncount should be 0.0 to get accurate increments.') - - 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%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - endif - ! get h_obs nz_data = CS%Inc(1)%nz_data allocate(h_obs(G%isd:G%ied,G%jsd:G%jed,nz_data), source=0.0) @@ -395,8 +412,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) enddo ! remap tracer on h_obs call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & - nz_data, tmp_h(1:nz_data), tmp_val2, & - h_neglect, h_neglect_edge) + nz_data, tmp_h(1:nz_data), tmp_val2) ! get increment from full field on h_obs do k=1,nz_data CS%Inc(1)%p(i,j,k) = CS%Inc(1)%p(i,j,k) - tmp_val2(k) @@ -408,8 +424,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) enddo ! remap tracer on h_obs call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & - nz_data, tmp_h(1:nz_data), tmp_val2, & - h_neglect, h_neglect_edge) + nz_data, tmp_h(1:nz_data), tmp_val2) ! get increment from full field on h_obs do k=1,nz_data CS%Inc(2)%p(i,j,k) = CS%Inc(2)%p(i,j,k) - tmp_val2(k) @@ -447,8 +462,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) enddo ! remap model u on hu_obs call remapping_core_h(CS%remap_cs, nz, hu(1:nz), tmp_val1, & - nz_data, hu_obs(1:nz_data), tmp_val2, & - h_neglect, h_neglect_edge) + nz_data, hu_obs(1:nz_data), tmp_val2) ! get increment from full field on h_obs do k=1,nz_data CS%Inc_u%p(i,j,k) = CS%Inc_u%p(i,j,k) - tmp_val2(k) @@ -483,8 +497,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) enddo ! remap model v on hv_obs call remapping_core_h(CS%remap_cs, nz, hv(1:nz), tmp_val1, & - nz_data, hv_obs(1:nz_data), tmp_val2, & - h_neglect, h_neglect_edge) + nz_data, hv_obs(1:nz_data), tmp_val2) ! get increment from full field on h_obs do k=1,nz_data CS%Inc_v%p(i,j,k) = CS%Inc_v%p(i,j,k) - tmp_val2(k) @@ -524,17 +537,20 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) type(oda_incupd_CS), pointer :: CS !< A pointer to the control structure for this module !! that is set by a previous call to initialize_oda_incupd (in). - real, allocatable, dimension(:) :: tmp_val2 ! data values on the increment grid - real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid - real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] + ! Local variables + real, allocatable, dimension(:) :: tmp_val2 ! data values remapped to increment grid, in rescaled units + ! like [S ~> ppt] for salinity. + real, dimension(SZK_(GV)) :: tmp_val1 ! data values on the model grid, in rescaled units + ! like [S ~> ppt] for salinity. + real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_t !< A temporary array for t increments [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_s !< A temporary array for s increments [S ~> ppt] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: tmp_u !< A temporary array for u increments [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: tmp_v !< A temporary array for v increments [L T-1 ~> m s-1] - real, allocatable, dimension(:,:,:) :: h_obs !< h of increments - real, allocatable, dimension(:) :: tmp_h !< temporary array for corrected h_obs + real, allocatable, dimension(:,:,:) :: h_obs !< h of increments [H ~> m or kg m-2] + real, allocatable, dimension(:) :: tmp_h !< temporary array for corrected h_obs [H ~> m or kg m-2] real, allocatable, dimension(:) :: hu_obs ! A column of observation-grid thicknesses at u points [H ~> m or kg m-2] real, allocatable, dimension(:) :: hv_obs ! A column of observation-grid thicknesses at v points [H ~> m or kg m-2] @@ -542,7 +558,6 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) integer :: isB, ieB, jsB, jeB ! integer :: ncount ! time step counter real :: inc_wt ! weight of the update for this time-step [nondim] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] real :: sum_h1, sum_h2 ! vertical sums of h's [H ~> m or kg m-2] character(len=256) :: mesg @@ -566,12 +581,6 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) write(mesg,'(f10.8)') inc_wt if (is_root_pe()) call MOM_error(NOTE,"updating fields with weight inc_wt:"//trim(mesg)) - 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%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - endif - ! get h_obs nz_data = CS%Inc(1)%nz_data allocate(h_obs(G%isd:G%ied,G%jsd:G%jed,nz_data), source=0.0) @@ -609,7 +618,7 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) enddo ! remap increment profile on model h call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data), tmp_val2, & - nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) + nz, h(i,j,1:nz), tmp_val1) do k=1,nz ! add increment to tracer on model h tv%T(i,j,k) = tv%T(i,j,k) + inc_wt * tmp_val1(k) @@ -621,8 +630,8 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) tmp_val2(k) = CS%Inc(2)%p(i,j,k) enddo ! remap increment profile on model h - call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data),tmp_val2,& - nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) + call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data), tmp_val2, & + nz, h(i,j,1:nz), tmp_val1) ! add increment to tracer on model h do k=1,nz tv%S(i,j,k) = tv%S(i,j,k) + inc_wt * tmp_val1(k) @@ -668,7 +677,7 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) enddo ! remap increment profile on hu call remapping_core_h(CS%remap_cs, nz_data, hu_obs(1:nz_data), tmp_val2, & - nz, hu(1:nz), tmp_val1, h_neglect, h_neglect_edge) + nz, hu(1:nz), tmp_val1) ! add increment to u-velocity on hu do k=1,nz u(i,j,k) = u(i,j,k) + inc_wt * tmp_val1(k) @@ -706,7 +715,7 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) enddo ! remap increment profile on hv call remapping_core_h(CS%remap_cs, nz_data, hv_obs(1:nz_data), tmp_val2, & - nz, hv(1:nz), tmp_val1, h_neglect, h_neglect_edge) + nz, hv(1:nz), tmp_val1) ! add increment to v-velocity on hv do k=1,nz v(i,j,k) = v(i,j,k) + inc_wt * tmp_val1(k) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 24d04b6b54..4e874294ed 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -55,6 +55,7 @@ module MOM_MEKE logical :: initialized = .false. !< True if this control structure has been initialized. ! Parameters real :: MEKE_FrCoeff !< Efficiency of conversion of ME into MEKE [nondim] + real :: MEKE_bhFrCoeff!< Efficiency of conversion of ME into MEKE by the biharmonic dissipation [nondim] real :: MEKE_GMcoeff !< Efficiency of conversion of PE into MEKE [nondim] real :: MEKE_GMECoeff !< Efficiency of conversion of MEKE into ME by GME [nondim] real :: MEKE_damping !< Local depth-independent MEKE dissipation rate [T-1 ~> s-1]. @@ -123,11 +124,14 @@ module MOM_MEKE logical :: debug !< If true, write out checksums of data for debugging integer :: eke_src !< Enum specifying whether EKE is stepped forward prognostically (default), !! read in from a file, or inferred via a neural network + logical :: sqg_use_MEKE !< If True, use MEKE%Le for the SQG vertical structure. type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output !>@{ Diagnostic handles integer :: id_MEKE = -1, id_Ue = -1, id_Kh = -1, id_src = -1 + integer :: id_src_adv = -1, id_src_mom_K4 = -1, id_src_btm_drag = -1 + integer :: id_src_GM = -1, id_src_mom_lp = -1, id_src_mom_bh = -1 integer :: id_Ub = -1, id_Ut = -1 - integer :: id_GM_src = -1, id_mom_src = -1, id_GME_snk = -1, id_decay = -1 + integer :: id_GM_src = -1, id_mom_src = -1, id_mom_src_bh = -1, id_GME_snk = -1, id_decay = -1 integer :: id_KhMEKE_u = -1, id_KhMEKE_v = -1, id_Ku = -1, id_Au = -1 integer :: id_Le = -1, id_gamma_b = -1, id_gamma_t = -1 integer :: id_Lrhines = -1, id_Leady = -1 @@ -192,6 +196,14 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h depth_tot, & ! The depth of the water column [H ~> m or kg m-2]. src, & ! The sum of all MEKE sources [L2 T-3 ~> W kg-1] (= m2 s-3). MEKE_decay, & ! A diagnostic of the MEKE decay timescale [T-1 ~> s-1]. + src_adv, & ! The MEKE source/tendency from the horizontal advection of MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). + src_mom_K4, & ! The MEKE source/tendency from the bihamornic of MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). + src_btm_drag, & ! The MEKE source/tendency from the bottom drag acting on MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). + src_GM, & ! The MEKE source/tendency from the thickness mixing (GM) [L2 T-3 ~> W kg-1] (= m2 s-3). + src_mom_lp, & ! The MEKE source/tendency from the Laplacian of the resolved flow [L2 T-3 ~> W kg-1] (= m2 s-3). + src_mom_bh, & ! The MEKE source/tendency from the biharmonic of the resolved flow [L2 T-3 ~> W kg-1] (= m2 s-3). + damp_rate_s1, & ! The MEKE damping rate computed at the 1st Strang splitting stage [T-1 ~> s-1]. + MEKE_current, & ! A copy of MEKE for use in computing the MEKE damping [L2 T-2 ~> m2 s-2]. drag_rate_visc, & ! Near-bottom velocity contribution to bottom drag [H T-1 ~> m s-1 or kg m-2 s-1] drag_rate, & ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. del2MEKE, & ! Laplacian of MEKE, used for bi-harmonic diffusion [T-2 ~> s-2]. @@ -200,8 +212,10 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h barotrFac2, & ! Ratio of EKE_barotropic / EKE [nondim] bottomFac2, & ! Ratio of EKE_bottom / EKE [nondim] tmp, & ! Temporary variable for computation of diagnostic velocities [L T-1 ~> m s-1] - equilibrium_value ! The equilibrium value of MEKE to be calculated at each - ! time step [L2 T-2 ~> m2 s-2] + equilibrium_value, & ! The equilibrium value of MEKE to be calculated at + ! each time step [L2 T-2 ~> m2 s-2] + damp_rate, & ! The MEKE damping rate [T-1 ~> s-1] + damping ! The net damping of a field after sdt_damp [nondim] real, dimension(SZIB_(G),SZJ_(G)) :: & MEKE_uflux, & ! The zonal advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m2 s-3]. @@ -215,6 +229,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h Kh_v, & ! The meridional diffusivity that is actually used [L2 T-1 ~> m2 s-1]. baroHv, & ! Depth integrated accumulated meridional mass flux [R Z L2 ~> kg]. drag_vel_v ! A piston velocity associated with bottom drag at v-points [H T-1 ~> m s-1 or kg m-2 s-1] + real :: bh_coeff ! Biharmonic part of efficiency conversion in total MEKE [nondim] real :: Kh_here ! The local horizontal viscosity [L2 T-1 ~> m2 s-1] real :: Inv_Kh_max ! The inverse of the local horizontal viscosity [T L-2 ~> s m-2] real :: K4_here ! The local horizontal biharmonic viscosity [L4 T-1 ~> m4 s-1] @@ -222,10 +237,12 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h real :: cdrag2 ! The square of the drag coefficient times unit conversion factors [H2 L-2 ~> nondim or kg2 m-6] real :: advFac ! The product of the advection scaling factor and 1/dt [T-1 ~> s-1] real :: mass_neglect ! A negligible mass [R Z ~> kg m-2]. - real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. real :: sdt ! dt to use locally [T ~> s] (could be scaled to accelerate) real :: sdt_damp ! dt for damping [T ~> s] (sdt could be split). + real :: damp_step ! Size of damping timestep relative to sdt [nondim] logical :: use_drag_rate ! Flag to indicate drag_rate is finite + logical :: any_damping_diags_s1 ! True if any damped diagnostics are enabled in first stage + logical :: any_damping_diags ! True if any damped diagnostics are enabled integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz real(kind=real32), dimension(size(MEKE%MEKE),NUM_FEATURES) :: features_array ! The array of features ! needed for the machine learning inference, with different @@ -253,17 +270,19 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h case(EKE_PROG) if (CS%debug) then if (allocated(MEKE%mom_src)) & - call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (allocated(MEKE%mom_src_bh)) & + call hchksum(MEKE%mom_src_bh, 'MEKE mom_src_bh', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%GME_snk)) & - call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%GM_src)) & - call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%MEKE)) & - call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, scale=US%L_T_to_m_s**2) - call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T, & + call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, unscale=US%L_T_to_m_s**2) + call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, unscale=US%s_to_T, & scalar_pair=.true.) call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=0, symmetric=.true., & - scale=GV%H_to_m*(US%L_to_m**2)) + unscale=GV%H_to_m*US%L_to_m**2) endif sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping @@ -272,7 +291,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! With a depth-dependent (and possibly strong) damping, it seems ! advisable to use Strang splitting between the damping and diffusion. - sdt_damp = sdt ; if (CS%MEKE_KH >= 0.0 .or. CS%MEKE_K4 >= 0.) sdt_damp = 0.5*sdt + damp_step = 1. + if (CS%MEKE_KH >= 0. .or. CS%MEKE_K4 >= 0.) damp_step = 0.5 + sdt_damp = sdt * damp_step ! Calculate depth integrated mass exchange if doing advection [R Z L2 ~> kg] if (CS%MEKE_advection_factor>0.) then @@ -375,12 +396,19 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%debug) then if (CS%visc_drag) & call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, & - scale=GV%H_to_mks*US%s_to_T, scalar_pair=.true.) - call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%RZ_to_kg_m2) - call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=GV%H_to_mks*US%s_to_T) + unscale=GV%H_to_mks*US%s_to_T, scalar_pair=.true.) + call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, unscale=US%RZ_to_kg_m2) + call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, unscale=GV%H_to_mks*US%s_to_T) call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) call hchksum(barotrFac2, 'MEKE barotrFac2', G%HI) - call hchksum(LmixScale, 'MEKE LmixScale', G%HI,scale=US%L_to_m) + call hchksum(LmixScale, 'MEKE LmixScale', G%HI, unscale=US%L_to_m) + endif + + if (allocated(MEKE%Le)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Le(i,j) = LmixScale(i,j) + enddo ; enddo endif ! Aggregate sources of MEKE (background, frictional and GM) @@ -389,11 +417,62 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h src(i,j) = CS%MEKE_BGsrc enddo ; enddo - if (allocated(MEKE%mom_src)) then + ! Initialize diagnostics + if (CS%id_src_adv > 0) src_adv(is:ie, js:je) = 0. + if (CS%id_src_GM > 0) src_GM(is:ie, js:je) = 0. + if (CS%id_src_mom_lp > 0) src_mom_lp(is:ie, js:je) = 0. + if (CS%id_src_mom_bh > 0) src_mom_bh(is:ie, js:je) = 0. + if (CS%id_src_mom_K4 > 0) src_mom_K4(is:ie, js:je) = 0. + if (CS%id_src_btm_drag > 0) src_btm_drag(is:ie, js:je) = 0. + + ! Identify any damped diagnostics in first stage of Strang splitting + any_damping_diags_s1 = any([ & + CS%id_src_GM > 0, & + CS%id_src_mom_lp > 0, & + CS%id_src_mom_bh > 0, & + CS%id_src_btm_drag > 0 & + ]) + + ! Identify any damped diagnostics + any_damping_diags = any([ & + any_damping_diags_s1, & + CS%id_src_adv > 0, & + CS%id_src_mom_K4 > 0 & + ]) + + if (CS%MEKE_FrCoeff > 0.) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src(i,j) = src(i,j) - CS%MEKE_FrCoeff * I_mass(i,j) * MEKE%mom_src(i,j) + enddo ; enddo + endif + + if (allocated(MEKE%mom_src_bh)) then + if (CS%MEKE_bhFrCoeff > 0. .and. CS%MEKE_FrCoeff > 0.) then + bh_coeff = CS%MEKE_bhFrCoeff - CS%MEKE_FrCoeff + else + bh_coeff = CS%MEKE_bhFrCoeff + endif + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*MEKE%mom_src(i,j) + src(i,j) = src(i,j) - bh_coeff * I_mass(i,j) * MEKE%mom_src_bh(i,j) enddo ; enddo + + if (CS%id_src_mom_lp > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_lp(i,j) = -CS%MEKE_FrCoeff * I_mass(i,j) & + * (MEKE%mom_src(i,j) - MEKE%mom_src_bh(i,j)) + enddo ; enddo + endif + + if (CS%id_src_mom_bh > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_bh(i,j) = -CS%MEKE_bhFrCoeff * I_mass(i,j) * MEKE%mom_src_bh(i,j) + enddo ; enddo + endif endif if (allocated(MEKE%GME_snk)) then @@ -415,6 +494,10 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) enddo ; enddo + + do j=js,je ; do i=is,ie + src_GM(i,j) = -CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) + enddo ; enddo endif endif @@ -427,12 +510,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif if (CS%debug) then - call hchksum(src, "MEKE src", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(src, "MEKE src", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T**3) endif ! Increase EKE by a full time-steps worth of source !$OMP parallel do default(shared) do j=js,je ; do i=is,ie + MEKE_current(i,j) = MEKE%MEKE(i,j) MEKE%MEKE(i,j) = (MEKE%MEKE(i,j) + sdt*src(i,j))*G%mask2dT(i,j) enddo ; enddo @@ -451,16 +535,75 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif ! First stage of Strang splitting + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - ldamping = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) - if (MEKE%MEKE(i,j) < 0.) ldamping = 0. + damp_rate(i,j) = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) + + if (MEKE%MEKE(i,j) < 0.) damp_rate(i,j) = 0. ! notice that the above line ensures a damping only if MEKE is positive, ! while leaving MEKE unchanged if it is negative - MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*ldamping) - MEKE_decay(i,j) = ldamping*G%mask2dT(i,j) enddo ; enddo + ! NOTE: MEKE%MEKE cannot use `damping` since we must preserve the existing + ! bit-reproducible solution. + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo + + if (any_damping_diags_s1) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damping(i,j) = 1. / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo + + if (CS%id_decay > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE_decay(i,j) = damp_rate(i,j) * G%mask2dT(i,j) + enddo ; enddo + endif + + if (CS%id_src_GM > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_GM(i,j) = src_GM(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_lp > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_lp(i,j) = src_mom_lp(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_bh > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_bh(i,j) = src_mom_bh(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_btm_drag > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_btm_drag(i,j) = -MEKE_current(i,j) * ( & + damp_step * (damp_rate(i,j) * damping(i,j)) & + ) + enddo ; enddo + + ! Store the effective damping rate if sdt is split + if (CS%MEKE_KH >= 0. .or. CS%MEKE_K4 >= 0.) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damp_rate_s1(i,j) = damp_rate(i,j) * damping(i,j) + enddo ; enddo + endif + endif + endif + if (CS%kh_flux_enabled .or. CS%MEKE_K4 >= 0.0) then ! Update MEKE in the halos for lateral or bi-harmonic diffusion call cpu_clock_begin(CS%id_clock_pass) @@ -528,6 +671,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h del4MEKE(i,j) = (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) + src_mom_K4(i,j) = (G%IareaT(i,j)*I_mass(i,j)) * & + ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & + (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) enddo ; enddo endif ! @@ -596,6 +742,15 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) enddo ; enddo + + if (CS%id_src_adv > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_adv(i,j) = (G%IareaT(i,j)*I_mass(i,j)) * & + ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & + (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) + enddo ; enddo + endif endif ! MEKE_KH>0 ! Add on bi-harmonic tendency @@ -608,29 +763,92 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Second stage of Strang splitting if (CS%MEKE_KH >= 0.0 .or. CS%MEKE_K4 >= 0.0) then - if (sdt>sdt_damp) then - ! Recalculate the drag rate, since MEKE has changed. - if (use_drag_rate) then + ! Recalculate the drag rate, since MEKE has changed. + if (use_drag_rate) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damp_rate(i,j) = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) + + if (MEKE%MEKE(i,j) < 0.) damp_rate(i,j) = 0. + ! notice that the above line ensures a damping only if MEKE is positive, + ! while leaving MEKE unchanged if it is negative + enddo ; enddo + + ! NOTE: MEKE%MEKE cannot use `damping` since we must preserve the + ! existing bit-reproducible solution. + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo + + if (any_damping_diags) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damping(i,j) = 1. / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo + + if (CS%id_decay > 0) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & - cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) + MEKE_decay(i,j) = damp_rate(i,j) * G%mask2dT(i,j) + enddo ; enddo + endif + + if (CS%id_src_GM > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_GM(i,j) = src_GM(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_lp > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_lp(i,j) = src_mom_lp(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_bh > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_bh(i,j) = src_mom_bh(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_adv > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_adv(i,j) = src_adv(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_K4 > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_K4(i,j) = src_mom_K4(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_btm_drag > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_btm_drag(i,j) = -MEKE_current(i,j) * (damp_step & + * ((damp_rate(i,j) + damp_rate_s1(i,j)) * damping(i,j)) & + ) enddo ; enddo endif - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - ldamping = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) - if (MEKE%MEKE(i,j) < 0.) ldamping = 0. - ! notice that the above line ensures a damping only if MEKE is positive, - ! while leaving MEKE unchanged if it is negative - MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*ldamping) - MEKE_decay(i,j) = ldamping*G%mask2dT(i,j) - enddo ; enddo endif endif ! MEKE_KH>=0 if (CS%debug) then - call hchksum(MEKE%MEKE, "MEKE post-update MEKE", G%HI, haloshift=0, scale=US%L_T_to_m_s**2) + call hchksum(MEKE%MEKE, "MEKE post-update MEKE", G%HI, haloshift=0, unscale=US%L_T_to_m_s**2) endif case(EKE_FILE) @@ -643,7 +861,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call pass_vector(u, v, G%Domain) call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, depth_tot, bottomFac2, barotrFac2, LmixScale) call ML_MEKE_calculate_features(G, GV, US, CS, MEKE%Rd_dx_h, u, v, tv, h, dt, features_array) - call predict_meke(G, CS, SIZE(h), Time, features_array, MEKE%MEKE) + call predict_MEKE(G, CS, SIZE(h), Time, features_array, MEKE%MEKE) case default call MOM_error(FATAL,"Invalid method specified for calculating EKE") end select @@ -693,7 +911,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo endif - if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au)) then + if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au) & + .or. allocated(MEKE%Le)) then call cpu_clock_begin(CS%id_clock_pass) call do_group_pass(CS%pass_Kh, G%Domain) call cpu_clock_end(CS%id_clock_pass) @@ -727,9 +946,16 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%id_KhMEKE_u>0) call post_data(CS%id_KhMEKE_u, Kh_u, CS%diag) if (CS%id_KhMEKE_v>0) call post_data(CS%id_KhMEKE_v, Kh_v, CS%diag) if (CS%id_src>0) call post_data(CS%id_src, src, CS%diag) + if (CS%id_src_adv>0) call post_data(CS%id_src_adv, src_adv, CS%diag) + if (CS%id_src_mom_K4>0) call post_data(CS%id_src_mom_K4, src_mom_K4, CS%diag) + if (CS%id_src_btm_drag>0) call post_data(CS%id_src_btm_drag, src_btm_drag, CS%diag) + if (CS%id_src_GM>0) call post_data(CS%id_src_GM, src_GM, CS%diag) + if (CS%id_src_mom_lp>0) call post_data(CS%id_src_mom_lp, src_mom_lp, CS%diag) + if (CS%id_src_mom_bh>0) call post_data(CS%id_src_mom_bh, src_mom_bh, CS%diag) if (CS%id_decay>0) call post_data(CS%id_decay, MEKE_decay, CS%diag) if (CS%id_GM_src>0) call post_data(CS%id_GM_src, MEKE%GM_src, CS%diag) if (CS%id_mom_src>0) call post_data(CS%id_mom_src, MEKE%mom_src, CS%diag) + if (CS%id_mom_src_bh>0) call post_data(CS%id_mom_src_bh, MEKE%mom_src_bh, CS%diag) if (CS%id_GME_snk>0) call post_data(CS%id_GME_snk, MEKE%GME_snk, CS%diag) if (CS%id_Le>0) call post_data(CS%id_Le, LmixScale, CS%diag) if (CS%id_gamma_b>0) then @@ -1210,6 +1436,10 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME "The efficiency of the conversion of mean energy into "//& "MEKE. If MEKE_FRCOEFF is negative, this conversion "//& "is not used or calculated.", units="nondim", default=-1.0) + call get_param(param_file, mdl, "MEKE_BHFRCOEFF", CS%MEKE_bhFrCoeff, & + "The efficiency of the conversion of mean energy into "//& + "MEKE by the biharmonic dissipation. If MEKE_bhFRCOEFF is negative, this conversion "//& + "is not used or calculated.", units="nondim", default=-1.0) call get_param(param_file, mdl, "MEKE_GMECOEFF", CS%MEKE_GMECoeff, & "The efficiency of the conversion of MEKE into mean energy "//& "by GME. If MEKE_GMECOEFF is negative, this conversion "//& @@ -1350,6 +1580,9 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME "computing beta in the expression of Rhines scale. Use 1 if full "//& "topographic beta effect is considered; use 0 if it's completely ignored.", & units="nondim", default=0.0) + call get_param(param_file, mdl, "SQG_USE_MEKE", CS%sqg_use_MEKE, & + "If true, the eddy scale of MEKE is used for the SQG vertical structure ",& + default=.false.) ! Nonlocal module parameters call get_param(param_file, mdl, "CDRAG", cdrag, & @@ -1399,6 +1632,33 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME if (.not. allocated(MEKE%MEKE)) CS%id_Ut = -1 CS%id_src = register_diag_field('ocean_model', 'MEKE_src', diag%axesT1, Time, & 'MEKE energy source', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + CS%id_src_adv = register_diag_field('ocean_model', 'MEKE_src_adv', diag%axesT1, Time, & + 'MEKE energy source from the horizontal advection of MEKE', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + CS%id_src_btm_drag = register_diag_field('ocean_model', 'MEKE_src_btm_drag', diag%axesT1, Time, & + 'MEKE energy source from the bottom drag acting on MEKE', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_K4 >= 0.) & + CS%id_src_mom_K4 = register_diag_field('ocean_model', 'MEKE_src_mom_K4', & + diag%axesT1, Time, 'MEKE energy source from the biharmonic of MEKE', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_GMcoeff >= 0.) & + CS%id_src_GM = register_diag_field('ocean_model', 'MEKE_src_GM', & + diag%axesT1, Time, 'MEKE energy source from the thickness mixing (GM scheme)', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_FrCoeff >= 0.) & + CS%id_src_mom_lp = register_diag_field('ocean_model', 'MEKE_src_mom_lp', & + diag%axesT1, Time, 'MEKE energy source from the Laplacian of resolved flows', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_bhFrCoeff >= 0.) & + CS%id_src_mom_bh = register_diag_field('ocean_model', 'MEKE_src_mom_bh', & + diag%axesT1, Time, 'MEKE energy source from the biharmonic of resolved flows', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_decay = register_diag_field('ocean_model', 'MEKE_decay', diag%axesT1, Time, & 'MEKE decay rate', 's-1', conversion=US%s_to_T) CS%id_GM_src = register_diag_field('ocean_model', 'MEKE_GM_src', diag%axesT1, Time, & @@ -1409,6 +1669,10 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME 'MEKE energy available from momentum', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (.not. allocated(MEKE%mom_src)) CS%id_mom_src = -1 + CS%id_mom_src_bh = register_diag_field('ocean_model', 'MEKE_mom_src_bh',diag%axesT1, Time, & + 'MEKE energy available from the biharmonic dissipation of momentum', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (.not. allocated(MEKE%mom_src_bh)) CS%id_mom_src_bh = -1 CS%id_GME_snk = register_diag_field('ocean_model', 'MEKE_GME_snk',diag%axesT1, Time, & 'MEKE energy lost to GME backscatter', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) @@ -1438,6 +1702,7 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME CS%id_clock_pass = cpu_clock_id('(Ocean continuity halo updates)', grain=CLOCK_ROUTINE) + ! Detect whether this instance of MEKE_init() is at the beginning of a run ! or after a restart. If at the beginning, we will initialize MEKE to a local ! equilibrium. @@ -1445,6 +1710,12 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME if (coldStart) CS%initialize = .false. if (CS%initialize) call MOM_error(WARNING, & "MEKE_init: Initializing MEKE with a local equilibrium balance.") + if (.not.query_initialized(MEKE%Le, "MEKE_Le", restart_CS) .and. allocated(MEKE%Le)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Le(i,j) = sqrt(G%areaT(i,j)) + enddo ; enddo + endif ! Set up group passes. In the case of a restart, these fields need a halo update now. if (allocated(MEKE%MEKE)) then @@ -1455,8 +1726,10 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME if (allocated(MEKE%Kh)) call create_group_pass(CS%pass_Kh, MEKE%Kh, G%Domain) if (allocated(MEKE%Ku)) call create_group_pass(CS%pass_Kh, MEKE%Ku, G%Domain) if (allocated(MEKE%Au)) call create_group_pass(CS%pass_Kh, MEKE%Au, G%Domain) + if (allocated(MEKE%Le)) call create_group_pass(CS%pass_Kh, MEKE%Le, G%Domain) - if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au)) & + if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au) & + .or. allocated(MEKE%Le)) & call do_group_pass(CS%pass_Kh, G%Domain) end function MEKE_init @@ -1665,12 +1938,14 @@ subroutine predict_MEKE(G, CS, npts, Time, features_array, MEKE) type(time_type), intent(in ) :: Time !< The current model time real(kind=real32), dimension(npts,num_features), intent(in ) :: features_array !< The array of features needed for machine - !! learning inference + !! learning inference, with different units + !! for the various subarrays [various] real, dimension(SZI_(G),SZJ_(G)), intent( out) :: MEKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2] integer :: db_return_code character(len=255), dimension(1) :: model_out, model_in character(len=255) :: time_suffix - real(kind=real32), dimension(SIZE(MEKE)) :: MEKE_vec + real(kind=real32), dimension(SIZE(MEKE)) :: MEKE_vec ! A one-dimensional array of eddy kinetic + ! energy [L2 T-2 ~> m2 s-2] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1692,6 +1967,8 @@ subroutine predict_MEKE(G, CS, npts, Time, features_array, MEKE) db_return_code = CS%client%unpack_tensor( model_out(1), MEKE_vec, shape(MEKE_vec) ) call cpu_clock_end(CS%id_unpack_tensor) + !### Does MEKE_vec need to be rescaled from [m2 s-2] to [L2 T-2 ~> m2 s-2] by + ! multiplying MEKE_vec by US%m_s_to_L_T**2 here? MEKE = reshape(MEKE_vec, shape(MEKE)) do j=js,je; do i=is,ie MEKE(i,j) = MIN(MAX(exp(MEKE(i,j)),0.),CS%eke_max) @@ -1738,10 +2015,11 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct ! Local variables - real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_GMECoeff ! Coefficients for various terms [nondim] + real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_bhFrCoeff, MEKE_GMECoeff ! Coefficients for various terms [nondim] real :: MEKE_KHCoeff, MEKE_viscCoeff_Ku, MEKE_viscCoeff_Au ! Coefficients for various terms [nondim] logical :: Use_KH_in_MEKE logical :: useMEKE + logical :: sqg_use_MEKE integer :: isd, ied, jsd, jed ! Determine whether this module will be used @@ -1750,11 +2028,13 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) ! Read these parameters to determine what should be in the restarts MEKE_GMcoeff = -1. ; call read_param(param_file,"MEKE_GMCOEFF",MEKE_GMcoeff) MEKE_FrCoeff = -1. ; call read_param(param_file,"MEKE_FRCOEFF",MEKE_FrCoeff) + MEKE_bhFrCoeff = -1. ; call read_param(param_file,"MEKE_bhFRCOEFF",MEKE_bhFrCoeff) MEKE_GMEcoeff = -1. ; call read_param(param_file,"MEKE_GMECOEFF",MEKE_GMEcoeff) MEKE_KhCoeff = 1. ; call read_param(param_file,"MEKE_KHCOEFF",MEKE_KhCoeff) MEKE_viscCoeff_Ku = 0. ; call read_param(param_file,"MEKE_VISCOSITY_COEFF_KU",MEKE_viscCoeff_Ku) MEKE_viscCoeff_Au = 0. ; call read_param(param_file,"MEKE_VISCOSITY_COEFF_AU",MEKE_viscCoeff_Au) Use_KH_in_MEKE = .false. ; call read_param(param_file,"USE_KH_IN_MEKE", Use_KH_in_MEKE) + sqg_use_MEKE = .false. ; call read_param(param_file,"SQG_USE_MEKE", sqg_use_MEKE) if (.not. useMEKE) return @@ -1766,8 +2046,12 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) longname="Mesoscale Eddy Kinetic Energy", units="m2 s-2", conversion=US%L_T_to_m_s**2) if (MEKE_GMcoeff>=0.) allocate(MEKE%GM_src(isd:ied,jsd:jed), source=0.0) - if (MEKE_FrCoeff>=0. .or. MEKE_GMECoeff>=0.) & + if (MEKE_FrCoeff>=0. .or. MEKE_bhFrCoeff>=0. .or. MEKE_GMECoeff>=0.) & allocate(MEKE%mom_src(isd:ied,jsd:jed), source=0.0) + if (MEKE_bhFrCoeff >= 0.) & + allocate(MEKE%mom_src_bh(isd:ied,jsd:jed), source=0.0) + if (MEKE_FrCoeff<0.) MEKE_FrCoeff = 0. + if (MEKE_bhFrCoeff<0.) MEKE_bhFrCoeff = 0. if (MEKE_GMECoeff>=0.) allocate(MEKE%GME_snk(isd:ied,jsd:jed), source=0.0) if (MEKE_KhCoeff>=0.) then allocate(MEKE%Kh(isd:ied,jsd:jed), source=0.0) @@ -1782,6 +2066,12 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) longname="Lateral viscosity from Mesoscale Eddy Kinetic Energy", & units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) endif + if (sqg_use_MEKE) then + allocate(MEKE%Le(isd:ied,jsd:jed), source=0.0) + call register_restart_field(MEKE%Le, "MEKE_Le", .false., restart_CS, & + longname="Eddy length scale from Mesoscale Eddy Kinetic Energy", & + units="m", conversion=US%L_to_m) + endif if (Use_Kh_in_MEKE) then allocate(MEKE%Kh_diff(isd:ied,jsd:jed), source=0.0) call register_restart_field(MEKE%Kh_diff, "MEKE_Kh_diff", .false., restart_CS, & @@ -1813,8 +2103,10 @@ subroutine MEKE_end(MEKE) if (allocated(MEKE%Kh)) deallocate(MEKE%Kh) if (allocated(MEKE%GME_snk)) deallocate(MEKE%GME_snk) if (allocated(MEKE%mom_src)) deallocate(MEKE%mom_src) + if (allocated(MEKE%mom_src_bh)) deallocate(MEKE%mom_src_bh) if (allocated(MEKE%GM_src)) deallocate(MEKE%GM_src) if (allocated(MEKE%MEKE)) deallocate(MEKE%MEKE) + if (allocated(MEKE%Le)) deallocate(MEKE%Le) end subroutine MEKE_end !> \namespace mom_meke @@ -1888,7 +2180,7 @@ end subroutine MEKE_end !! \f$ U_b \f$ is a constant background bottom velocity scale and is !! typically not used (i.e. set to zero). !! -!! Following Jansen et al., 2015, the projection of eddy energy on to the bottom +!! Following \cite jansen2015, the projection of eddy energy on to the bottom !! is given by the ratio of bottom energy to column mean energy: !! \f[ !! \gamma_b^2 = \frac{E_b}{E} = \gamma_{d0} @@ -1920,12 +2212,12 @@ end subroutine MEKE_end !! \f[ \kappa_M = \gamma_\kappa \sqrt{ \gamma_t^2 U_e^2 A_\Delta } \f] !! !! where \f$ A_\Delta \f$ is the area of the grid cell. -!! Following Jansen et al., 2015, we now use +!! Following \cite jansen2015, we now use !! !! \f[ \kappa_M = \gamma_\kappa l_M \sqrt{ \gamma_t^2 U_e^2 } \f] !! !! where \f$ \gamma_\kappa \in [0,1] \f$ is a non-dimensional factor and, -!! following Jansen et al., 2015, \f$\gamma_t^2\f$ is the ratio of barotropic +!! following \cite jansen2015, \f$\gamma_t^2\f$ is the ratio of barotropic !! eddy energy to column mean eddy energy given by !! \f[ !! \gamma_t^2 = \frac{E_t}{E} = \left( 1 + c_{t} \frac{L_d}{L_f} \right)^{-\frac{1}{4}} diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90 index e51f558ce3..38bdd72452 100644 --- a/src/parameterizations/lateral/MOM_MEKE_types.F90 +++ b/src/parameterizations/lateral/MOM_MEKE_types.F90 @@ -11,6 +11,8 @@ module MOM_MEKE_types real, allocatable :: GM_src(:,:) !< MEKE source due to thickness mixing (GM) [R Z L2 T-3 ~> W m-2]. real, allocatable :: mom_src(:,:) !< MEKE source from lateral friction in the !! momentum equations [R Z L2 T-3 ~> W m-2]. + real, allocatable :: mom_src_bh(:,:) !< MEKE source from the biharmonic part of the lateral friction in the + !! momentum equations [R Z L2 T-3 ~> W m-2]. real, allocatable :: GME_snk(:,:) !< MEKE sink from GME backscatter in the momentum equations [R Z L2 T-3 ~> W m-2]. real, allocatable :: Kh(:,:) !< The MEKE-derived lateral mixing coefficient [L2 T-1 ~> m2 s-1]. real, allocatable :: Kh_diff(:,:) !< Uses the non-MEKE-derived thickness diffusion coefficient to diffuse @@ -22,6 +24,7 @@ module MOM_MEKE_types !! backscatter from unresolved eddies (see Jansen and Held, 2014). real, allocatable :: Au(:,:) !< The MEKE-derived lateral biharmonic viscosity !! coefficient [L4 T-1 ~> m4 s-1]. + real, allocatable :: Le(:,:) !< Eddy length scale [L m] ! Parameters real :: KhTh_fac = 1.0 !< Multiplier to map Kh(MEKE) to KhTh [nondim] diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 4a794a19fe..a11b8a232e 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -50,6 +50,9 @@ module MOM_hor_visc !! limited to guarantee stability. logical :: better_bound_Kh !< If true, use a more careful bounding of the !! Laplacian viscosity to guarantee stability. + logical :: EY24_EBT_BS !! If true, use an equivalent barotropic backscatter + !! with a stabilizing kill switch in MEKE, + !< developed by Yankovsky et al. 2024 logical :: bound_Ah !< If true, the biharmonic coefficient is locally !! limited to guarantee stability. logical :: better_bound_Ah !< If true, use a more careful bounding of the @@ -60,6 +63,15 @@ module MOM_hor_visc !! the viscosity bounds to the theoretical maximum !! for stability without considering other terms [nondim]. !! The default is 0.8. + real :: KS_coef !< A nondimensional coefficient on the biharmonic viscosity that sets the + !! kill switch for backscatter. Default is 1.0 [nondim]. + real :: KS_timescale !< A timescale for computing CFL limit for turning off backscatter [T ~> s]. + logical :: backscatter_underbound !< If true, the bounds on the biharmonic viscosity are allowed + !! to increase where the Laplacian viscosity is negative (due to + !! backscatter parameterizations) beyond the largest timestep-dependent + !! stable values of biharmonic viscosity when no Laplacian viscosity is + !! applied. The default is true for historical reasons, but this option + !! probably should not be used as it can lead to numerical instabilities. logical :: Smagorinsky_Kh !< If true, use Smagorinsky nonlinear eddy !! viscosity. KH is the background value. logical :: Smagorinsky_Ah !< If true, use a biharmonic form of Smagorinsky @@ -88,6 +100,8 @@ module MOM_hor_visc !! in setting the corner-point viscosities when USE_KH_BG_2D=True. real :: Kh_bg_min !< The minimum value allowed for Laplacian horizontal !! viscosity [L2 T-1 ~> m2 s-1]. The default is 0.0. + logical :: FrictWork_bug !< If true, retain an answer-changing bug in calculating FrictWork, + !! which cancels the h in thickness flux and the h at velocity point. logical :: use_land_mask !< Use the land mask for the computation of thicknesses !! at velocity locations. This eliminates the dependence on !! arbitrary values over land or outside of the domain. @@ -115,6 +129,7 @@ module MOM_hor_visc real :: min_grid_Ah !< Minimun horizontal biharmonic viscosity used to !! limit grid Reynolds number [L4 T-1 ~> m4 s-1] logical :: use_cont_thick !< If true, thickness at velocity points adopts h[uv] in BT_cont from continuity solver. + logical :: use_cont_thick_bug !< If true, retain an answer-changing bug for thickness at velocity points. type(ZB2020_CS) :: ZB2020 !< Zanna-Bolton 2020 control structure. logical :: use_ZB2020 !< If true, use Zanna-Bolton 2020 parameterization. @@ -136,6 +151,7 @@ module MOM_hor_visc real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & Kh_Max_xx, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. Ah_Max_xx, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. + Ah_Max_xx_KS, & !< The maximum permitted biharmonic viscosity for kill switch [L4 T-1 ~> m4 s-1]. n1n2_h, & !< Factor n1*n2 in the anisotropic direction tensor at h-points [nondim] n1n1_m_n2n2_h, & !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points [nondim] grid_sp_h2, & !< Harmonic mean of the squares of the grid [L2 ~> m2] @@ -154,6 +170,7 @@ module MOM_hor_visc real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & Kh_Max_xy, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. Ah_Max_xy, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. + Ah_Max_xy_KS, & !< The maximum permitted biharmonic viscosity for kill switch [L4 T-1 ~> m4 s-1]. n1n2_q, & !< Factor n1*n2 in the anisotropic direction tensor at q-points [nondim] n1n1_m_n2n2_q !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points [nondim] @@ -221,8 +238,13 @@ module MOM_hor_visc integer :: id_vort_xy_q = -1, id_div_xx_h = -1 integer :: id_sh_xy_q = -1, id_sh_xx_h = -1 integer :: id_FrictWork = -1, id_FrictWorkIntz = -1 + integer :: id_FrictWork_bh = -1, id_FrictWorkIntz_bh = -1 integer :: id_FrictWork_GME = -1 integer :: id_normstress = -1, id_shearstress = -1 + integer :: id_visc_limit_h = -1, id_visc_limit_q = -1 + integer :: id_visc_limit_h_flag = -1, id_visc_limit_q_flag = -1 + integer :: id_visc_limit_h_frac = -1, id_visc_limit_q_frac = -1 + integer :: id_BS_coeff_h = -1, id_BS_coeff_q = -1 !>@} end type hor_visc_CS @@ -241,7 +263,7 @@ module MOM_hor_visc !! u(is-2:ie+2,js-2:je+2) !! v(is-2:ie+2,js-2:je+2) !! h(is-1:ie+1,js-1:je+1) or up to h(is-2:ie+2,js-2:je+2) with some Leith options. -subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & +subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, GV, US, & CS, tv, dt, OBC, BT, TD, ADp, hu_cont, hv_cont) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -251,6 +273,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uh !< The zonal volume transport [H L2 T-1 ~> m3 s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vh !< The meridional volume transport [H L2 T-1 ~> m3 s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: diffu !< Zonal acceleration due to convergence of !! along-coordinate stress tensor [L T-2 ~> m s-2] @@ -270,9 +296,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, type(thickness_diffuse_CS), optional, intent(in) :: TD !< Thickness diffusion control structure type(accel_diag_ptrs), optional, intent(in) :: ADp !< Acceleration diagnostics real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: hu_cont !< Layer thickness at u-points [H ~> m or kg m-2]. + optional, intent(inout) :: hu_cont !< Layer thickness at u-points [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(in) :: hv_cont !< Layer thickness at v-points [H ~> m or kg m-2]. + optional, intent(inout) :: hv_cont !< Layer thickness at v-points [H ~> m or kg m-2]. ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -300,6 +326,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME [L2 T-2 ~> m2 s-2] bhstr_xx, & ! A copy of str_xx that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R L2 T-3 ~> W m-2] + FrictWorkIntz_bh, & ! depth integrated energy dissipated by biharmonic lateral friction [R L2 T-3 ~> W m-2] grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] @@ -308,7 +335,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] m_leithy, & ! Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2] Ah_sq, & ! The square of the biharmonic viscosity [L8 T-2 ~> m8 s-2] - htot ! The total thickness of all layers [H ~> m or kg m-2] + htot, & ! The total thickness of all layers [H ~> m or kg m-2] + str_xx_BS ! The diagonal term in the stress tensor due to backscatter [H L2 T-2 ~> m3 s-2 or kg s-2] real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] @@ -333,7 +361,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [L-1 T-1 ~> m-1 s-1] hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] ! This form guarantees that hq/hu < 4. - GME_effic_q ! The filtered efficiency of the GME terms at q points [nondim] + GME_effic_q, & ! The filtered efficiency of the GME terms at q points [nondim] + str_xy_BS ! The cross term in the stress tensor due to backscatter [H L2 T-2 ~> m3 s-2 or kg s-2] real :: grad_vel_mag_bt_q ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] real :: boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] @@ -343,6 +372,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, vort_xy_q, & ! vertical vorticity at corner points [T-1 ~> s-1] sh_xy_q, & ! horizontal shearing strain at corner points [T-1 ~> s-1] GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] + visc_limit_q, & ! used to stabilize the EY24_EBT_BS backscatter [nondim] + visc_limit_q_flag, & ! determines whether backscatter is shut off [nondim] + visc_limit_q_frac, & ! determines how close backscatter is to shutting off [nondim] + BS_coeff_q, & ! A diagnostic array of the backscatter coefficient [L2 T-1 ~> m2 s-1] ShSt ! A diagnostic array of shear stress [T-1 ~> s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & KH_u_GME, & !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] @@ -355,14 +388,19 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] dz, & ! Height change across layers [Z ~> m] FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] + FrictWork_bh, & ! work done by the biharmonic MKE dissipation mechanisms [R L2 T-3 ~> W m-2] FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] div_xx_h, & ! horizontal divergence [T-1 ~> s-1] sh_xx_h, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] - NoSt ! A diagnostic array of normal stress [T-1 ~> s-1]. + NoSt, & ! A diagnostic array of normal stress [T-1 ~> s-1]. + BS_coeff_h ! A diagnostic array of the backscatter coefficient [L2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & grid_Re_Kh, & ! Grid Reynolds number for Laplacian horizontal viscosity at h points [nondim] grid_Re_Ah, & ! Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] - GME_coeff_h ! GME coefficient at h-points [L2 T-1 ~> m2 s-1] + GME_coeff_h, & ! GME coefficient at h-points [L2 T-1 ~> m2 s-1] + visc_limit_h, & ! Used to stabilize the EY24_EBT_BS backscatter [nondim] + visc_limit_h_flag, & ! determines whether backscatter is shut off [nondim] + visc_limit_h_frac ! determines how close backscatter is to shutting off [nondim] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & u_smooth ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & @@ -382,6 +420,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] real :: h_min ! Minimum h at the 4 neighboring velocity points [H ~> m] + real :: Kh_max_here ! The local maximum Laplacian viscosity for stability [L2 T-1 ~> m2 s-1] real :: RoScl ! The scaling function for MEKE source term [nondim] real :: FatH ! abs(f) at h-point for MEKE source term [T-1 ~> s-1] real :: local_strain ! Local variable for interpolating computed strain rates [T-1 ~> s-1]. @@ -407,11 +446,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, logical :: use_MEKE_Ku logical :: use_MEKE_Au logical :: use_cont_huv + logical :: use_kh_struct integer :: is_vort, ie_vort, js_vort, je_vort ! Loop ranges for vorticity terms integer :: is_Kh, ie_Kh, js_Kh, je_Kh ! Loop ranges for thickness point viscosities integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n real :: inv_PI3, inv_PI2, inv_PI6 ! Powers of the inverse of pi [nondim] + real :: tmp ! Fields evaluated on active layers, used for constructing 3D stress fields ! NOTE: The position of these declarations can impact performance, due to the @@ -422,6 +463,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real, dimension(SZIB_(G),SZJB_(G)) :: & Ah, & ! biharmonic viscosity (h or q) [L4 T-1 ~> m4 s-1] Kh, & ! Laplacian viscosity (h or q) [L2 T-1 ~> m2 s-1] + Kh_BS, & ! Laplacian antiviscosity [L2 T-1 ~> m2 s-1] Shear_mag, & ! magnitude of the shear (h or q) [T-1 ~> s-1] vert_vort_mag, & ! magnitude of the vertical vorticity gradient (h or q) [L-1 T-1 ~> m-1 s-1] vert_vort_mag_smooth, & ! magnitude of gradient of smoothed vertical vorticity (h or q) [L-1 T-1 ~> m-1 s-1] @@ -438,6 +480,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI6 = inv_PI3 * inv_PI3 + if (CS%EY24_EBT_BS) then + visc_limit_h(:,:,:) = 0. + visc_limit_q(:,:,:) = 0. + visc_limit_h_flag(:,:,:) = 0. + visc_limit_q_flag(:,:,:) = 0. + visc_limit_h_frac(:,:,:) = 0. + visc_limit_q_frac(:,:,:) = 0. + endif + m_leithy(:,:) = 0.0 ! Initialize if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then @@ -454,6 +505,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_FrictWorkIntz > 0) find_FrictWork = .true. if (allocated(MEKE%mom_src)) find_FrictWork = .true. + use_kh_struct = allocated(VarMix%BS_struct) backscat_subround = 0.0 if (find_FrictWork .and. allocated(MEKE%mom_src) .and. (MEKE%backscatter_Ro_c > 0.0) .and. & (MEKE%backscatter_Ro_Pow /= 0.0)) & @@ -464,6 +516,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, use_MEKE_Au = allocated(MEKE%Au) use_cont_huv = CS%use_cont_thick .and. present(hu_cont) .and. present(hv_cont) + if (use_cont_huv .and. .not.CS%use_cont_thick_bug) then + call pass_vector(hu_cont, hv_cont, G%domain, To_All+Scalar_Pair, halo=2) + endif rescale_Kh = .false. if (VarMix%use_variable_mixing) then @@ -581,7 +636,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call pass_vector(KH_u_GME, KH_v_GME, G%domain, To_All+Scalar_Pair) if (CS%debug) & - call uvchksum("GME KH[u,v]_GME", KH_u_GME, KH_v_GME, G%HI, haloshift=2, scale=US%L_to_m**2*US%s_to_T) + call uvchksum("GME KH[u,v]_GME", KH_u_GME, KH_v_GME, G%HI, haloshift=2, unscale=US%L_to_m**2*US%s_to_T) endif ! use_GME @@ -608,28 +663,28 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP parallel do default(none) & !$OMP shared( & - !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & + !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, uh, vh, & !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP is_vort, ie_vort, js_vort, je_vort, & !$OMP is_Kh, ie_Kh, js_Kh, je_Kh, & - !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & + !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, use_kh_struct, & !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, use_cont_huv, slope_x, slope_y, dz, & !$OMP backscat_subround, GME_effic_h, GME_effic_q, & !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & - !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & + !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_bh, FrictWork_GME, & !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt, hu_cont, hv_cont & !$OMP ) & !$OMP private( & - !$OMP i, j, k, n, & + !$OMP i, j, k, n, tmp, & !$OMP dudx, dudy, dvdx, dvdy, sh_xx, sh_xy, h_u, h_v, & !$OMP Del2u, Del2v, DY_dxBu, DX_dyBu, sh_xx_bt, sh_xy_bt, & !$OMP str_xx, str_xy, bhstr_xx, bhstr_xy, str_xx_GME, str_xy_GME, & !$OMP vort_xy, vort_xy_dx, vort_xy_dy, div_xx, div_xx_dx, div_xx_dy, & !$OMP grad_div_mag_h, grad_div_mag_q, grad_vort_mag_h, grad_vort_mag_q, & !$OMP grad_vort, grad_vort_qg, grad_vort_mag_h_2d, grad_vort_mag_q_2d, & - !$OMP sh_xx_sq, sh_xy_sq, & - !$OMP meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, h_min, hrat_min, visc_bound_rem, & + !$OMP sh_xx_sq, sh_xy_sq, meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, & + !$OMP h_min, hrat_min, visc_bound_rem, Kh_max_here, & !$OMP grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & !$OMP dDel2vdx, dDel2udy, Del2vort_q, Del2vort_h, KE, & @@ -637,7 +692,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP dudx_smooth, dudy_smooth, dvdx_smooth, dvdy_smooth, & !$OMP vort_xy_smooth, vort_xy_dx_smooth, vort_xy_dy_smooth, & !$OMP sh_xx_smooth, sh_xy_smooth, & - !$OMP vert_vort_mag_smooth, m_leithy, Ah_sq, AhLthy & + !$OMP vert_vort_mag_smooth, m_leithy, Ah_sq, AhLthy, & + !$OMP Kh_BS, str_xx_bs, str_xy_bs, bs_coeff_h, bs_coeff_q & + !$OMP ) & + !$OMP firstprivate( & + !$OMP visc_limit_h, visc_limit_h_frac, visc_limit_h_flag, & + !$OMP visc_limit_q, visc_limit_q_frac, visc_limit_q_flag & !$OMP ) do k=1,nz @@ -696,7 +756,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! in OBCs, which are not ordinarily be necessary, and might not be necessary ! even with OBCs if the accelerations are zeroed at OBC points, in which ! case the j-loop for h_u could collapse to j=js=1,je+1. -RWH - if (CS%use_land_mask) then + if (use_cont_huv) then + do j=js-2,je+2 ; do I=Isq-1,Ieq+1 + h_u(I,j) = hu_cont(I,j,k) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 + h_v(i,J) = hv_cont(i,J,k) + enddo ; enddo + elseif (CS%use_land_mask) then do j=js-2,je+2 ; do I=is-2,Ieq+1 h_u(I,j) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) enddo ; enddo @@ -712,16 +779,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif - ! The following should obviously be combined with the previous block if adopted. - if (use_cont_huv) then - do j=js-2,je+2 ; do I=Isq-1,Ieq+1 - h_u(I,j) = hu_cont(I,j,k) - enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 - h_v(i,J) = hv_cont(i,J,k) - enddo ; enddo - endif - ! Adjust contributions to shearing strain and interpolated values of ! thicknesses on open boundaries. if (apply_OBC) then ; do n=1,OBC%number_of_segments @@ -897,7 +954,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! Vorticity - if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy) .or. (CS%id_vort_xy_q>0)) then + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy) .or. (CS%id_vort_xy_q>0) .or. CS%use_ZB2020) then if (CS%no_slip) then do J=js_vort,je_vort ; do I=is_vort,ie_vort vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) @@ -1064,12 +1121,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, h_min = min(h_u(I,j), h_u(I-1,j), h_v(i,J), h_v(i,J-1)) hrat_min(i,j) = min(1.0, h_min / (h(i,j,k) + h_neglect)) enddo ; enddo - - if (CS%better_bound_Kh) then - do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - visc_bound_rem(i,j) = 1.0 - enddo ; enddo - endif endif if (CS%Laplacian) then @@ -1132,16 +1183,28 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Kh(i,j) = max(Kh(i,j), CS%Kh_bg_min) enddo ; enddo - if (use_MEKE_Ku) then + if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then ! *Add* the MEKE contribution (which might be negative) - if (CS%res_scale_MEKE) then - do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) - enddo ; enddo + if (use_kh_struct) then + if (CS%res_scale_MEKE) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) * VarMix%BS_struct(i,j,k) + enddo ; enddo + else + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) + enddo ; enddo + endif else - do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) - enddo ; enddo + if (CS%res_scale_MEKE) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) + enddo ; enddo + else + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) + enddo ; enddo + endif endif endif @@ -1153,15 +1216,21 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! Newer method of bounding for stability - if (CS%better_bound_Kh) then + if ((CS%better_bound_Kh) .and. (CS%better_bound_Ah)) then do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - if (Kh(i,j) >= hrat_min(i,j) * CS%Kh_Max_xx(i,j)) then + visc_bound_rem(i,j) = 1.0 + Kh_max_here = hrat_min(i,j) * CS%Kh_Max_xx(i,j) + if (Kh(i,j) >= Kh_max_here) then visc_bound_rem(i,j) = 0.0 - Kh(i,j) = hrat_min(i,j) * CS%Kh_Max_xx(i,j) - else ! if (Kh(i,j) > 0.0) then !### Change this to avoid a zero denominator. - visc_bound_rem(i,j) = 1.0 - Kh(i,j) / (hrat_min(i,j) * CS%Kh_Max_xx(i,j)) + Kh(i,j) = Kh_max_here + elseif ((Kh(i,j) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then + visc_bound_rem(i,j) = 1.0 - Kh(i,j) / Kh_max_here endif enddo ; enddo + elseif (CS%better_bound_Kh) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = min(Kh(i,j), hrat_min(i,j) * CS%Kh_Max_xx(i,j)) + enddo ; enddo endif ! In Leith+E parameterization Kh is computed after Ah in the biharmonic loop. @@ -1336,6 +1405,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif + if (CS%EY24_EBT_BS) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + tmp = CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xx_KS(i,j) + visc_limit_h(i,j,k) = tmp + visc_limit_h_frac(i,j,k) = Ah(i,j) / (CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xx_KS(i,j)) + if (Ah(i,j) >= tmp) then + visc_limit_h_flag(i,j,k) = 1. + endif + enddo ; enddo + endif + if ((CS%id_Ah_h>0) .or. CS%debug .or. CS%use_Leithy) then do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah_h(i,j,k) = Ah(i,j) @@ -1351,7 +1431,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif - if (CS%id_grid_Re_Ah>0) then + if (CS%id_grid_Re_Ah > 0) then do j=js,je ; do i=is,ie KE = 0.125 * (((u(I,j,k) + u(I-1,j,k))**2) + ((v(i,J,k) + v(i,J-1,k))**2)) grid_Ah = max(Ah(i,j), CS%min_grid_Ah) @@ -1373,6 +1453,35 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif ! Get biharmonic coefficient at h points and biharmonic part of str_xx + ! Backscatter using MEKE + if (CS%EY24_EBT_BS) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (visc_limit_h_flag(i,j,k) > 0) then + Kh_BS(i,j) = 0. + else + if (use_kh_struct) then + Kh_BS(i,j) = MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) + else + Kh_BS(i,j) = MEKE%Ku(i,j) + endif + endif + enddo ; enddo + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx_BS(i,j) = -Kh_BS(i,j) * sh_xx(i,j) + enddo ; enddo + + if (CS%id_BS_coeff_h>0) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + BS_coeff_h(i,j,k) = Kh_BS(i,j) + enddo ; enddo + endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx(i,j) = str_xx(i,j) + str_xx_BS(i,j) + enddo ; enddo + endif ! Backscatter + if (CS%biharmonic) then ! Gradient of Laplacian, for use in bi-harmonic term do J=js-1,Jeq ; do I=is-1,Ieq @@ -1428,11 +1537,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, hrat_min(I,J) = min(1.0, h_min / (hq(I,J) + h_neglect)) enddo ; enddo - if (CS%better_bound_Kh) then - do J=js-1,Jeq ; do I=is-1,Ieq - visc_bound_rem(I,J) = 1.0 - enddo ; enddo - endif endif if (CS%no_slip) then @@ -1532,10 +1636,19 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Kh(I,J) = max(Kh(I,J), CS%Kh_bg_min) ! Place a floor on the viscosity, if desired. - if (use_MEKE_Ku) then + if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then ! *Add* the MEKE contribution (might be negative) - Kh(I,J) = Kh(I,J) + 0.25*( (MEKE%Ku(i,j) + MEKE%Ku(i+1,j+1)) + & - (MEKE%Ku(i+1,j) + MEKE%Ku(i,j+1)) ) * meke_res_fn + if (use_kh_struct) then + Kh(I,J) = Kh(I,J) + 0.25*( ((MEKE%Ku(i,j)*VarMix%BS_struct(i,j,k)) + & + (MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + & + ((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + & + (MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) ) * meke_res_fn + else + Kh(I,J) = Kh(I,J) + 0.25*( (MEKE%Ku(i,j) + & + MEKE%Ku(i+1,j+1)) + & + (MEKE%Ku(i+1,j) + & + MEKE%Ku(i,j+1)) ) * meke_res_fn + endif endif if (CS%anisotropic) & @@ -1543,13 +1656,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Kh(I,J) = Kh(I,J) + CS%Kh_aniso * CS%n1n2_q(I,J)**2 ! Newer method of bounding for stability - if (CS%better_bound_Kh) then - if (Kh(I,J) >= hrat_min(I,J) * CS%Kh_Max_xy(I,J)) then + if ((CS%better_bound_Kh) .and. (CS%better_bound_Ah)) then + visc_bound_rem(I,J) = 1.0 + Kh_max_here = hrat_min(I,J) * CS%Kh_Max_xy(I,J) + if (Kh(I,J) >= Kh_max_here) then visc_bound_rem(I,J) = 0.0 - Kh(I,J) = hrat_min(I,J) * CS%Kh_Max_xy(I,J) - elseif (hrat_min(I,J)*CS%Kh_Max_xy(I,J)>0.) then !### Change to elseif (Kh(I,J) > 0.0) then - visc_bound_rem(I,J) = 1.0 - Kh(I,J) / (hrat_min(I,J) * CS%Kh_Max_xy(I,J)) + Kh(I,J) = Kh_max_here + elseif ((Kh(I,J) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then + visc_bound_rem(I,J) = 1.0 - Kh(I,J) / Kh_max_here endif + elseif (CS%better_bound_Kh) then + Kh(I,J) = min(Kh(I,J), hrat_min(I,J) * CS%Kh_Max_xy(I,J)) endif ! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points @@ -1658,6 +1775,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif + if (CS%EY24_EBT_BS) then + do J=js-1,Jeq ; do I=is-1,Ieq + tmp = CS%KS_coef *hrat_min(I,J) * CS%Ah_Max_xy_KS(I,J) + visc_limit_q(I,J,k) = tmp + visc_limit_q_frac(i,j,k) = Ah(i,j) / (CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xy_KS(i,j)) + if (Ah(I,J) >= tmp) then + visc_limit_q_flag(I,J,k) = 1. + endif + enddo ; enddo + endif + ! Leith+E doesn't recompute Ah at q points, it just interpolates it from h to q points if (CS%use_Leithy) then do J=js-1,Jeq ; do I=is-1,Ieq @@ -1682,6 +1810,41 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif ! Get Ah at q points and biharmonic part of str_xy + ! Backscatter using MEKE + if (CS%EY24_EBT_BS) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (visc_limit_q_flag(I,J,k) > 0) then + Kh_BS(I,J) = 0. + else + if (use_kh_struct) then + Kh_BS(I,J) = 0.25*( ((MEKE%Ku(i,j)*VarMix%BS_struct(i,j,k)) + & + (MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + & + ((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + & + (MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) ) + else + Kh_BS(I,J) = 0.25*( (MEKE%Ku(i,j) + & + MEKE%Ku(i+1,j+1)) + & + (MEKE%Ku(i+1,j) + & + MEKE%Ku(i,j+1)) ) + endif + endif + enddo ; enddo + + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy_BS(I,J) = -Kh_BS(I,J) * (sh_xy(I,J)) + enddo ; enddo + + if (CS%id_BS_coeff_q>0) then + do J=js-1,Jeq ; do I=is-1,Ieq + BS_coeff_q(I,J,k) = Kh_BS(I,J) + enddo ; enddo + endif + + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = str_xy(I,J) + str_xy_BS(I,J) + enddo ; enddo + endif ! Backscatter + if (CS%use_GME) then ! The wider halo here is to permit one pass of smoothing without a halo update. do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 @@ -1781,45 +1944,178 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo endif - if (find_FrictWork) then ; do j=js,je ; do i=is,ie - ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) - ! This is the old formulation that includes energy diffusion - FrictWork(i,j,k) = GV%H_to_RZ * ( & - ((str_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & - - (str_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & - + 0.25*(( (str_xy(I,J) * & - (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) & - + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) & - + (str_xy(I-1,J-1) * & - (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) & - + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) & - + ( (str_xy(I-1,J) * & - (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) & - + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) & - + (str_xy(I,J-1) * & - (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) & - + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) ) - enddo ; enddo ; endif - - if (CS%use_GME) then ; do j=js,je ; do i=is,ie - ! Diagnose str_xx_GME*d_x u - str_yy_GME*d_y v + str_xy_GME*(d_y u + d_x v) - ! This is the old formulation that includes energy diffusion - FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & - ((str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & - - (str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & - + 0.25*(( (str_xy_GME(I,J) * & + if (find_FrictWork) then + if (CS%FrictWork_bug) then + ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion + do j=js,je ; do i=is,ie + FrictWork(i,j,k) = GV%H_to_RZ * ( & + ((str_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & + - (str_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & + + 0.25*(( (str_xy(I,J) * & + (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) & + + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) & + + (str_xy(I-1,J-1) * & + (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) & + + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) & + + ( (str_xy(I-1,J) * & + (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) & + + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) & + + (str_xy(I,J-1) * & + (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) & + + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) ) + enddo ; enddo + else + do j=js,je ; do i=is,ie + FrictWork(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((str_xx(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (str_xx(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((str_xy(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(str_xy(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((str_xy(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(str_xy(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + + enddo ; enddo + endif + + if (CS%EY24_EBT_BS) then + do j=js,je ; do i=is,ie + FrictWork(i,j,k) = (1. - visc_limit_h_flag(i,j,k)) * FrictWork(i,j,k) + enddo ; enddo + endif + endif + + if (CS%id_FrictWork_bh>0 .or. CS%id_FrictWorkIntz_bh > 0 .or. allocated(MEKE%mom_src_bh)) then + if (CS%FrictWork_bug) then + ! Diagnose bhstr_xx*d_x u - bhstr_yy*d_y v + bhstr_xy*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion !cyc + do j=js,je ; do i=is,ie + FrictWork_bh(i,j,k) = GV%H_to_RZ * ( & + ((bhstr_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & + - (bhstr_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & + + 0.25*(( (bhstr_xy(I,J) * & (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) & + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) & - + (str_xy_GME(I-1,J-1) * & + + (bhstr_xy(I-1,J-1) * & (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) & + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) & - + ( (str_xy_GME(I-1,J) * & + + ( (bhstr_xy(I-1,J) * & (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) & + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) & - + (str_xy_GME(I,J-1) * & + + (bhstr_xy(I,J-1) * & (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) & + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) ) - enddo ; enddo ; endif + enddo ; enddo + else + do j=js,je ; do i=is,ie + ! Diagnose bhstr_xx*d_x u - bhstr_yy*d_y v + bhstr_xy*(d_y u + d_x v) + FrictWork_bh(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((bhstr_xx(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (bhstr_xx(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((bhstr_xy(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(bhstr_xy(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((bhstr_xy(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(bhstr_xy(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + enddo ; enddo + endif + + if (CS%EY24_EBT_BS) then + do j=js,je ; do i=is,ie + FrictWork_bh(i,j,k) = (1. - visc_limit_h_flag(i,j,k)) * FrictWork_bh(i,j,k) + enddo ; enddo + endif + endif + + if (CS%use_GME) then + if (CS%FrictWork_bug) then ; do j=js,je ; do i=is,ie + ! Diagnose str_xx_GME*d_x u - str_yy_GME*d_y v + str_xy_GME*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion + FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & + ((str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & + - (str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & + + 0.25*(( (str_xy_GME(I,J) * & + (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) & + + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) & + + (str_xy_GME(I-1,J-1) * & + (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) & + + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) & + + ( (str_xy_GME(I-1,J) * & + (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) & + + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) & + + (str_xy_GME(I,J-1) * & + (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) & + + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) ) + enddo ; enddo + else ; do j=js,je ; do i=is,ie + FrictWork_GME(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((str_xx_GME(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (str_xx_GME(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((str_xy_GME(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(str_xy_GME(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((str_xy_GME(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(str_xy_GME(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + enddo ; enddo ; endif + endif ! Make a similar calculation as for FrictWork above but accumulating into ! the vertically integrated MEKE source term, and adjusting for any @@ -1829,6 +2125,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, do j=js,je ; do i=is,ie MEKE%mom_src(i,j) = 0. enddo ; enddo + + if (allocated(MEKE%mom_src_bh)) then + do j=js,je ; do i=is,ie + MEKE%mom_src_bh(i,j) = 0. + enddo ; enddo + endif + if (allocated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie MEKE%GME_snk(i,j) = 0. @@ -1842,7 +2145,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Shear_mag_bc = sqrt(sh_xx(i,j) * sh_xx(i,j) + & 0.25*(((sh_xy(I-1,J-1)*sh_xy(I-1,J-1)) + (sh_xy(I,J)*sh_xy(I,J))) + & ((sh_xy(I-1,J)*sh_xy(I-1,J)) + (sh_xy(I,J-1)*sh_xy(I,J-1))))) - if (CS%answer_date > 20190101) then + if ((CS%answer_date > 20190101) .and. (CS%answer_date < 20241201)) then FatH = (US%s_to_T*FatH)**MEKE%backscatter_Ro_pow ! f^n ! Note the hard-coded dimensional constant in the following line that can not ! be rescaled for dimensional consistency. @@ -1860,36 +2163,30 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_RZ * ( & - (((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & - - ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & - + 0.25*( (((str_xy(I,J)-RoScl*bhstr_xy(I,J)) * & - (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) & - + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) & - + ((str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1)) * & - (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) & - + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) & - + (((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J)) * & - (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) & - + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) & - + ((str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1)) * & - (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) & - + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) ) + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + (FrictWork(i,j,k) - RoScl*FrictWork_bh(i,j,k)) + + if (allocated(MEKE%mom_src_bh)) & + MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) & + + (FrictWork_bh(i,j,k) - RoScl * FrictWork_bh(i,j,k)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) enddo ; enddo - endif ! MEKE%backscatter_Ro_c - do j=js,je ; do i=is,ie - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) - enddo ; enddo + if (allocated(MEKE%mom_src_bh)) then + do j=js,je ; do i=is,ie + MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) + FrictWork_bh(i,j,k) + enddo ; enddo + endif + endif ! MEKE%backscatter_Ro_c if (CS%use_GME .and. allocated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie MEKE%GME_snk(i,j) = MEKE%GME_snk(i,j) + FrictWork_GME(i,j,k) enddo ; enddo endif - endif ! find_FrictWork and associated(mom_src) - enddo ! end of k loop ! Offer fields for diagnostic averaging. @@ -1898,6 +2195,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_diffu>0) call post_data(CS%id_diffu, diffu, CS%diag) if (CS%id_diffv>0) call post_data(CS%id_diffv, diffv, CS%diag) if (CS%id_FrictWork>0) call post_data(CS%id_FrictWork, FrictWork, CS%diag) + if (CS%id_FrictWork_bh>0) call post_data(CS%id_FrictWork_bh, FrictWork_bh, CS%diag) if (CS%id_Ah_h>0) call post_data(CS%id_Ah_h, Ah_h, CS%diag) if (CS%id_grid_Re_Ah>0) call post_data(CS%id_grid_Re_Ah, grid_Re_Ah, CS%diag) if (CS%id_div_xx_h>0) call post_data(CS%id_div_xx_h, div_xx_h, CS%diag) @@ -1917,14 +2215,24 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_dudy_bt > 0) call post_data(CS%id_dudy_bt, dudy_bt, CS%diag) if (CS%id_dvdx_bt > 0) call post_data(CS%id_dvdx_bt, dvdx_bt, CS%diag) endif + if (CS%EY24_EBT_BS) then + if (CS%id_visc_limit_h>0) call post_data(CS%id_visc_limit_h, visc_limit_h, CS%diag) + if (CS%id_visc_limit_q>0) call post_data(CS%id_visc_limit_q, visc_limit_q, CS%diag) + if (CS%id_visc_limit_h_frac>0) call post_data(CS%id_visc_limit_h_frac, visc_limit_h_frac, CS%diag) + if (CS%id_visc_limit_q_frac>0) call post_data(CS%id_visc_limit_q_frac, visc_limit_q_frac, CS%diag) + if (CS%id_visc_limit_h_flag>0) call post_data(CS%id_visc_limit_h_flag, visc_limit_h_flag, CS%diag) + if (CS%id_visc_limit_q_flag>0) call post_data(CS%id_visc_limit_q_flag, visc_limit_q_flag, CS%diag) + if (CS%id_BS_coeff_h>0) call post_data(CS%id_BS_coeff_h, BS_coeff_h, CS%diag) + if (CS%id_BS_coeff_q>0) call post_data(CS%id_BS_coeff_q, BS_coeff_q, CS%diag) + endif if (CS%debug) then if (CS%Laplacian) then - call hchksum(Kh_h, "Kh_h", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) - call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call hchksum(Kh_h, "Kh_h", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T) + call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T) endif - if (CS%biharmonic) call hchksum(Ah_h, "Ah_h", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) - if (CS%biharmonic) call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + if (CS%biharmonic) call hchksum(Ah_h, "Ah_h", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) + if (CS%biharmonic) call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) endif if (CS%id_FrictWorkIntz > 0) then @@ -1937,6 +2245,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call post_data(CS%id_FrictWorkIntz, FrictWorkIntz, CS%diag) endif + if (CS%id_FrictWorkIntz_bh > 0) then + do j=js,je + do i=is,ie ; FrictWorkIntz_bh(i,j) = FrictWork_bh(i,j,1) ; enddo + do k=2,nz ; do i=is,ie + FrictWorkIntz_bh(i,j) = FrictWorkIntz_bh(i,j) + FrictWork_bh(i,j,k) + enddo ; enddo + enddo + call post_data(CS%id_FrictWorkIntz_bh, FrictWorkIntz_bh, CS%diag) + endif + if (present(ADp)) then ! Diagnostics of the fractional thicknesses times momentum budget terms ! 3D diagnostics of hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. @@ -1968,9 +2286,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, end subroutine horizontal_viscosity -!> Allocates space for and calculates static variables used by horizontal_viscosity(). +!> Allocates space for and calculates static variables used by horizontal_viscosity. !! hor_visc_init calculates and stores the values of a number of metric functions that -!! are used in horizontal_viscosity(). +!! are used in horizontal_viscosity. subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) type(time_type), intent(in) :: Time !< Current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -2021,6 +2339,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) logical :: split ! If true, use the split time stepping scheme. ! If false and USE_GME = True, issue a FATAL error. logical :: use_MEKE ! If true, the MEKE parameterization is in use. + real :: backscatter_Ro_c ! Coefficient in Rossby number function for backscatter [nondim] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags character(len=200) :: inputdir, filename ! Input file names and paths character(len=80) :: Kh_var ! Input variable names @@ -2052,18 +2371,33 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) + + ! Determine whether HOR_VISC_ANSWER_DATE is used, and avoid logging it if it is not used. + call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & + default=.false., do_not_log=.true.) + backscatter_Ro_c = 0.0 + if (use_MEKE) call get_param(param_file, mdl, "MEKE_BACKSCAT_RO_C", backscatter_Ro_c, & + "The coefficient in the Rossby number function for scaling the biharmonic "//& + "frictional energy source. Setting to non-zero enables the Rossby number function.", & + units="nondim", default=0.0, do_not_log=.true.) + call get_param(param_file, mdl, "HOR_VISC_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the horizontal "//& - "viscosity calculations. Values below 20190101 recover the answers from the "//& - "end of 2018, while higher values use updated and more robust forms of the "//& - "same expressions.", & - default=default_answer_date, do_not_log=.not.GV%Boussinesq) - if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + "viscosity calculations. Values between 20190102 and 20241201 recover the "//& + "answers from the end of 2018, while higher values use updated and more robust "//& + "forms of the same expressions.", & + default=default_answer_date, do_not_log=(.not.GV%Boussinesq).or.(backscatter_Ro_c==0.0)) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20241201) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "USE_CONT_THICKNESS", CS%use_cont_thick, & - "If true, use thickness at velocity points from continuity solver. This option"//& + "If true, use thickness at velocity points from continuity solver. This option "//& "currently only works with split mode.", default=.false.) + call get_param(param_file, mdl, "USE_CONT_THICKNESS_BUG", CS%use_cont_thick_bug, & + "If true, retain an answer-changing halo update bug when "//& + "USE_CONT_THICKNESS=True. This is not recommended.", & + default=.false., do_not_log=.not.CS%use_cont_thick) + call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & "If true, use a Laplacian horizontal viscosity.", & default=.false.) @@ -2109,8 +2443,6 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "The nondimensional Laplacian Leith constant, "//& "often set to 1.0", units="nondim", default=0.0, & fail_if_missing=CS%Leith_Kh, do_not_log=.not.CS%Leith_Kh) - call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & - default=.false., do_not_log=.true.) call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, & "If true, the viscosity contribution from MEKE is scaled by "//& "the resolution function.", default=.false., & @@ -2124,8 +2456,13 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, the Laplacian coefficient is locally limited "//& "to be stable with a better bounding than just BOUND_KH.", & default=CS%bound_Kh, do_not_log=.not.CS%Laplacian) + call get_param(param_file, mdl, "EY24_EBT_BS", CS%EY24_EBT_BS, & + "If true, use the the backscatter scheme (EBT mode with kill switch)"//& + "developed by Yankovsky et al. (2024). ", & + default=.false., do_not_log=.not.CS%Laplacian) if (.not.CS%Laplacian) CS%bound_Kh = .false. if (.not.CS%Laplacian) CS%better_bound_Kh = .false. + if (.not.(CS%Laplacian.and.use_MEKE)) CS%EY24_EBT_BS = .false. call get_param(param_file, mdl, "ANISOTROPIC_VISCOSITY", CS%anisotropic, & "If true, allow anistropic viscosity in the Laplacian "//& "horizontal viscosity.", default=.false., & @@ -2208,6 +2545,16 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "so that the biharmonic Reynolds number is equal to this.", & units="nondim", default=0.0, do_not_log=.not.CS%biharmonic) + call get_param(param_file, mdl, "BACKSCATTER_UNDERBOUND", CS%backscatter_underbound, & + "If true, the bounds on the biharmonic viscosity are allowed to "//& + "increase where the Laplacian viscosity is negative (due to backscatter "//& + "parameterizations) beyond the largest timestep-dependent stable values of "//& + "biharmonic viscosity when no Laplacian viscosity is applied. The default "//& + "is true for historical reasons, but this option probably should not be used "//& + "because it can contribute to numerical instabilities.", & + default=.true., do_not_log=.not.((CS%better_bound_Kh).and.(CS%better_bound_Ah))) + !### The default for BACKSCATTER_UNDERBOUND should be false. + call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, & "The nondimensional biharmonic Smagorinsky constant, "//& "typically 0.015 - 0.06.", units="nondim", default=0.0, & @@ -2266,6 +2613,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "viscosity bounds to the theoretical maximum for "//& "stability without considering other terms.", units="nondim", & default=0.8, do_not_log=.not.(CS%better_bound_Ah .or. CS%better_bound_Kh)) + call get_param(param_file, mdl, "KILL_SWITCH_COEF", CS%KS_coef, & + "A nondimensional coefficient on the biharmonic viscosity that "// & + "sets the kill switch for backscatter. Default is 1.0.", units="nondim", & + default=1.0, do_not_log=.not.(CS%EY24_EBT_BS)) call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & "If true, no slip boundary conditions are used; otherwise "//& "free slip boundary conditions are assumed. The "//& @@ -2282,6 +2633,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, retain an answer-changing horizontal indexing bug in setting "//& "the corner-point viscosities when USE_KH_BG_2D=True. This is "//& "not recommended.", default=.false., do_not_log=.not.CS%use_Kh_bg_2d) + call get_param(param_file, mdl, "FRICTWORK_BUG", CS%FrictWork_bug, & + "If true, retain an answer-changing bug in calculating "//& + "the FrictWork, which cancels the h in thickness flux and the h at velocity point. This is"//& + "not recommended.", default=.true.) call get_param(param_file, mdl, "USE_GME", CS%use_GME, & "If true, use the GM+E backscatter scheme in association \n"//& @@ -2327,6 +2682,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) fail_if_missing=.true.) Idt = 1.0 / dt endif + call get_param(param_file, mdl, "KILL_SWITCH_TIMESCALE", CS%KS_timescale, & + "A timescale for computing the CFL limit for viscosity "// & + "that determines when backscatter is shut off. Default is DT.", & + default= dt , units="s", scale=US%s_to_T, do_not_log=.not.(CS%EY24_EBT_BS)) + if (CS%no_slip .and. CS%biharmonic) & call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// & "at the same time in MOM.") @@ -2350,11 +2710,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%grid_sp_h2(isd:ied,jsd:jed)) ; CS%grid_sp_h2(:,:) = 0.0 ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0 ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0 - if (CS%bound_Kh .or. CS%better_bound_Kh) then + if (CS%bound_Kh .or. CS%better_bound_Kh .or. CS%EY24_EBT_BS) then ALLOC_(CS%Kh_Max_xx(Isd:Ied,Jsd:Jed)) ; CS%Kh_Max_xx(:,:) = 0.0 ALLOC_(CS%Kh_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_Max_xy(:,:) = 0.0 endif - if (CS%Smagorinsky_Kh) then + if (CS%Smagorinsky_Kh .or. CS%EY24_EBT_BS) then ALLOC_(CS%Laplac2_const_xx(isd:ied,jsd:jed)) ; CS%Laplac2_const_xx(:,:) = 0.0 ALLOC_(CS%Laplac2_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Laplac2_const_xy(:,:) = 0.0 endif @@ -2412,6 +2772,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%Ah_Max_xx(isd:ied,jsd:jed)) ; CS%Ah_Max_xx(:,:) = 0.0 ALLOC_(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy(:,:) = 0.0 endif + if (CS%EY24_EBT_BS) then + ALLOC_(CS%Ah_Max_xx_KS(isd:ied,jsd:jed)) ; CS%Ah_Max_xx_KS(:,:) = 0.0 + ALLOC_(CS%Ah_Max_xy_KS(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy_KS(:,:) = 0.0 + endif if (CS%Smagorinsky_Ah) then ALLOC_(CS%Biharm_const_xx(isd:ied,jsd:jed)) ; CS%Biharm_const_xx(:,:) = 0.0 ALLOC_(CS%Biharm_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Biharm_const_xy(:,:) = 0.0 @@ -2632,8 +2996,8 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%Kh_Max_xy(I,J) = CS%bound_coef * 0.25 * Idt / denom enddo ; enddo if (CS%debug) then - call hchksum(CS%Kh_Max_xx, "Kh_Max_xx", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) - call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call hchksum(CS%Kh_Max_xx, "Kh_Max_xx", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T) + call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T) endif endif ! The biharmonic bounds should avoid overshoots when CS%bound_coef < 0.5, but @@ -2670,8 +3034,13 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) (CS%DX_dyT(i,j)*((G%IdxCv(i,J)*v0v(i,J)) + (G%IdxCv(i,J-1)*v0v(i,J-1))))) * & max(G%IdxCv(i,J)*G%IareaCv(i,J), G%IdxCv(i,J-1)*G%IareaCv(i,J-1)) ) ) CS%Ah_Max_xx(I,J) = 0.0 - if (denom > 0.0) & + if (denom > 0.0) then CS%Ah_Max_xx(I,J) = CS%bound_coef * 0.5 * Idt / denom + if (CS%EY24_EBT_BS) then + CS%Ah_Max_xx_KS(i,j) = CS%bound_coef * 0.5 / (CS%KS_timescale * denom) + endif + endif + enddo ; enddo do J=js-1,Jeq ; do I=is-1,Ieq denom = max( & @@ -2684,12 +3053,17 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) (CS%DY_dxBu(I,J)*((v0v(i+1,J)*G%IdyCv(i+1,J)) + (v0v(i,J)*G%IdyCv(i,J))))) * & max(G%IdyCv(i,J)*G%IareaCv(i,J), G%IdyCv(i+1,J)*G%IareaCv(i+1,J)) ) ) CS%Ah_Max_xy(I,J) = 0.0 - if (denom > 0.0) & + if (denom > 0.0) then CS%Ah_Max_xy(I,J) = CS%bound_coef * 0.5 * Idt / denom + if (CS%EY24_EBT_BS) then + CS%Ah_Max_xy_KS(i,j) = CS%bound_coef * 0.5 / (CS%KS_timescale * denom) + endif + endif + enddo ; enddo if (CS%debug) then - call hchksum(CS%Ah_Max_xx, "Ah_Max_xx", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) - call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + call hchksum(CS%Ah_Max_xx, "Ah_Max_xx", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) + call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) endif endif ! Register fields for output from this module. @@ -2784,6 +3158,20 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) 'Biharmonic Horizontal Viscosity at q Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T) CS%id_grid_Re_Ah = register_diag_field('ocean_model', 'grid_Re_Ah', diag%axesTL, Time, & 'Grid Reynolds number for the Biharmonic horizontal viscosity at h points', 'nondim') + if (CS%EY24_EBT_BS) then + CS%id_visc_limit_h_flag = register_diag_field('ocean_model', 'visc_limit_h_flag', diag%axesTL, Time, & + 'Locations where the biharmonic viscosity reached the better_bound limiter at h points', 'nondim') + CS%id_visc_limit_q_flag = register_diag_field('ocean_model', 'visc_limit_q_flag', diag%axesBL, Time, & + 'Locations where the biharmonic viscosity reached the better_bound limiter at q points', 'nondim') + CS%id_visc_limit_h = register_diag_field('ocean_model', 'visc_limit_h', diag%axesTL, Time, & + 'Value of the biharmonic viscosity limiter at h points', 'nondim') + CS%id_visc_limit_q = register_diag_field('ocean_model', 'visc_limit_q', diag%axesBL, Time, & + 'Value of the biharmonic viscosity limiter at q points', 'nondim') + CS%id_visc_limit_h_frac = register_diag_field('ocean_model', 'visc_limit_h_frac', diag%axesTL, Time, & + 'Value of the biharmonic viscosity limiter at h points', 'nondim') + CS%id_visc_limit_q_frac = register_diag_field('ocean_model', 'visc_limit_q_frac', diag%axesBL, Time, & + 'Value of the biharmonic viscosity limiter at q points', 'nondim') + endif if (CS%id_grid_Re_Ah > 0) & ! Compute the smallest biharmonic viscosity capable of modifying the @@ -2835,6 +3223,14 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) endif + + if (CS%EY24_EBT_BS) then + CS%id_BS_coeff_h = register_diag_field('ocean_model', 'BS_coeff_h', diag%axesTL, Time, & + 'Backscatter coefficient at h points', 'm2 s-1') + CS%id_BS_coeff_q = register_diag_field('ocean_model', 'BS_coeff_q', diag%axesBL, Time, & + 'Backscatter coefficient at q points', 'm2 s-1') + endif + CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,& 'Integral work done by lateral friction terms. If GME is turned on, this '//& 'includes the GME contribution.', & @@ -2845,6 +3241,12 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) cmor_field_name='dispkexyfo', & cmor_long_name='Depth integrated ocean kinetic energy dissipation due to lateral friction',& cmor_standard_name='ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction') + CS%id_FrictWork_bh = register_diag_field('ocean_model','FrictWork_bh',diag%axesTL,Time,& + 'Integral work done by the biharmonic lateral friction terms.', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + CS%id_FrictWorkIntz_bh = register_diag_field('ocean_model','FrictWorkIntz_bh',diag%axesT1,Time,& + 'Depth integrated work done by the biharmonic lateral friction', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) end subroutine hor_visc_init @@ -3075,6 +3477,9 @@ subroutine hor_visc_end(CS) if (CS%bound_Ah) then DEALLOC_(CS%Ah_Max_xx) ; DEALLOC_(CS%Ah_Max_xy) endif + if (CS%EY24_EBT_BS) then + DEALLOC_(CS%Ah_Max_xx_KS) ; DEALLOC_(CS%Ah_Max_xy_KS) + endif if (CS%Smagorinsky_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) endif @@ -3103,25 +3508,25 @@ subroutine hor_visc_end(CS) end subroutine hor_visc_end !> \namespace mom_hor_visc !! -!! This module contains the subroutine horizontal_viscosity() that calculates the +!! \section section_horizontal_viscosity Horizontal viscosity in MOM +!! +!! This module contains the subroutine horizontal_viscosity that calculates the !! effects of horizontal viscosity, including parameterizations of the value of -!! the viscosity itself. horizontal_viscosity() calculates the acceleration due to +!! the viscosity itself. Subroutine horizontal_viscosity calculates the acceleration due to !! some combination of a biharmonic viscosity and a Laplacian viscosity. Either or !! both may use a coefficient that depends on the shear and strain of the flow. !! All metric terms are retained. The Laplacian is calculated as the divergence of -!! a stress tensor, using the form suggested by Smagorinsky (1993). The biharmonic +!! a stress tensor, using the form suggested by \cite Smagorinsky1993. The biharmonic !! is calculated by twice applying the divergence of the stress tensor that is !! used to calculate the Laplacian, but without the dependence on thickness in the !! first pass. This form permits a variable viscosity, and indicates no !! acceleration for either resting fluid or solid body rotation. !! -!! The form of the viscous accelerations is discussed extensively in Griffies and -!! Hallberg (2000), and the implementation here follows that discussion closely. -!! We use the notation of Smith and McWilliams (2003) with the exception that the +!! The form of the viscous accelerations is discussed extensively in \cite griffies2000, +!! and the implementation here follows that discussion closely. +!! We use the notation of \cite Smith2003 with the exception that the !! isotropic viscosity is \f$\kappa_h\f$. !! -!! \section section_horizontal_viscosity Horizontal viscosity in MOM -!! !! In general, the horizontal stress tensor can be written as !! \f[ !! {\bf \sigma} = @@ -3169,7 +3574,7 @@ end subroutine hor_visc_end !! \f} !! !! The viscosity \f$\kappa_h\f$ may either be a constant or variable. For example, -!! \f$\kappa_h\f$ may vary with the shear, as proposed by Smagorinsky (1993). +!! \f$\kappa_h\f$ may vary with the shear, as proposed by \cite Smagorinsky1993. !! !! The accelerations resulting form the divergence of the stress tensor are !! \f{eqnarray*}{ @@ -3267,8 +3672,8 @@ end subroutine hor_visc_end !! !! \subsection section_anisotropic_viscosity Anisotropic viscosity !! -!! Large et al., 2001, proposed enhancing viscosity in a particular direction and the -!! approach was generalized in Smith and McWilliams, 2003. We use the second form of their +!! \cite Large2001 proposed enhancing viscosity in a particular direction and the +!! approach was generalized in \cite Smith2003. We use the second form of their !! two coefficient anisotropic viscosity (section 4.3). We also replace their !! \f$A^\prime\f$ and $D$ such that \f$2A^\prime = 2 \kappa_h + D\f$ and !! \f$\kappa_a = D\f$ so that \f$\kappa_h\f$ can be considered the isotropic diff --git a/src/parameterizations/lateral/MOM_interface_filter.F90 b/src/parameterizations/lateral/MOM_interface_filter.F90 index 42782e86a1..12bda8c020 100644 --- a/src/parameterizations/lateral/MOM_interface_filter.F90 +++ b/src/parameterizations/lateral/MOM_interface_filter.F90 @@ -142,9 +142,9 @@ subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS) if (CS%debug) then call uvchksum("Kh_[uv]", Lsm2_u, Lsm2_v, G%HI, haloshift=hs, & - scale=US%L_to_m**2, scalar_pair=.true.) - call hchksum(h, "interface_filter_1 h", G%HI, haloshift=hs+1, scale=GV%H_to_m) - call hchksum(e, "interface_filter_1 e", G%HI, haloshift=hs+1, scale=US%Z_to_m) + unscale=US%L_to_m**2, scalar_pair=.true.) + call hchksum(h, "interface_filter_1 h", G%HI, haloshift=hs+1, unscale=GV%H_to_m) + call hchksum(e, "interface_filter_1 e", G%HI, haloshift=hs+1, unscale=US%Z_to_m) endif ! Calculate uhD, vhD from h, e, Lsm2_u, Lsm2_v @@ -225,10 +225,10 @@ subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS) if (CS%debug) then call uvchksum("interface_filter [uv]hD", uhD, vhD, & - G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + G%HI, haloshift=0, unscale=GV%H_to_m*US%L_to_m**2) call uvchksum("interface_filter [uv]htr", uhtr, vhtr, & - G%HI, haloshift=0, scale=US%L_to_m**2*GV%H_to_m) - call hchksum(h, "interface_filter h", G%HI, haloshift=0, scale=GV%H_to_m) + G%HI, haloshift=0, unscale=US%L_to_m**2*GV%H_to_m) + call hchksum(h, "interface_filter h", G%HI, haloshift=0, unscale=GV%H_to_m) endif end subroutine interface_filter @@ -480,7 +480,7 @@ end subroutine interface_filter_end !! filter, depending on the order of the filter, or to the slope for a Laplacian !! filter !! \f[ -!! \vec{\psi} = - \kappa_h {\nabla \eta - \eta_smooth} +!! \vec{\psi} = - \kappa_h {\nabla \eta - \eta_{smooth}} !! \f] !! !! The result of the above expression is subsequently bounded by minimum and maximum values, including a diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index b1e84a74f7..c7101ac6b7 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -5,27 +5,29 @@ module MOM_internal_tides ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_checksums, only : hchksum use MOM_debugging, only : is_NaN use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_axis_init use MOM_diag_mediator, only : disable_averaging, enable_averages use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_diag_mediator, only : axes_grp, define_axes_group -use MOM_domains, only : AGRID, To_South, To_West, To_All -use MOM_domains, only : create_group_pass, do_group_pass, pass_var +use MOM_domains, only : AGRID, To_South, To_West, To_All, CGRID_NE +use MOM_domains, only : create_group_pass, pass_var, pass_vector use MOM_domains, only : group_pass_type, start_group_pass, complete_group_pass use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_forcing_type,only : forcing use MOM_grid, only : ocean_grid_type use MOM_int_tide_input, only: int_tide_input_CS, get_input_TKE, get_barotropic_tidal_vel use MOM_io, only : slasher, MOM_read_data, file_exists, axis_info -use MOM_io, only : set_axis_info, get_axis_info +use MOM_io, only : set_axis_info, get_axis_info, stdout use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_restart, only : lock_check, restart_registry_lock use MOM_spatial_means, only : global_area_integral use MOM_string_functions, only: extract_real use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs +use MOM_variables, only : surface, thermo_var_ptrs, vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speeds, wave_speed_CS, wave_speed_init @@ -35,7 +37,7 @@ module MOM_internal_tides public propagate_int_tide, register_int_tide_restarts public internal_tides_init, internal_tides_end -public get_lowmode_loss +public get_lowmode_loss, get_lowmode_diffusivity !> This control structure has parameters for the MOM_internal_tides module type, public :: int_tide_CS ; private @@ -55,6 +57,13 @@ module MOM_internal_tides !! areas when estimating CFL numbers. Without aggress_adjust, !! the default is false; it is always true with aggress_adjust. logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. + logical :: update_Kd !< If true, the scheme will modify the diffusivities seen by the dynamics + logical :: apply_refraction !< If false, skip refraction (for debugging) + logical :: apply_propagation !< If False, do not propagate energy (for debugging) + logical :: debug !< If true, use debugging prints + logical :: init_forcing_only !< if True, add TKE forcing only at first step (for debugging) + logical :: force_posit_En !< if True, remove subroundoff negative values (needs enhancement) + logical :: add_tke_forcing = .true. !< Whether to add forcing, used by init_forcing_only real, allocatable, dimension(:,:) :: fraction_tidal_input !< how the energy from one tidal component is distributed @@ -80,32 +89,48 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:,:) :: cp !< horizontal phase speed [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:,:,:) :: TKE_leak_loss - !< energy lost due to misc background processes [R Z3 T-3 ~> W m-2] + !< energy lost due to misc background processes [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_quad_loss - !< energy lost due to quadratic bottom drag [R Z3 T-3 ~> W m-2] + !< energy lost due to quadratic bottom drag [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_Froude_loss - !< energy lost due to wave breaking [R Z3 T-3 ~> W m-2] + !< energy lost due to wave breaking [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: TKE_itidal_loss_fixed - !< Fixed part of the energy lost due to small-scale drag [R Z3 L-2 ~> kg m-2] here; + !< Fixed part of the energy lost due to small-scale drag [H Z2 L-2 ~> kg m-2] here; !! This will be multiplied by N and the squared near-bottom velocity (and by !! the near-bottom density in non-Boussinesq mode) to get the energy losses !! in [R Z4 H-1 L-2 ~> kg m-2 or m] real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss - !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] + !< energy lost due to small-scale wave drag [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_residual_loss - !< internal tide energy loss due to the residual at slopes [R Z3 T-3 ~> W m-2] + !< internal tide energy loss due to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:,:,:,:) :: TKE_slope_loss + !< internal tide energy loss due to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:) :: TKE_input_glo_dt + !< The energy input to the internal waves * dt [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, allocatable, dimension(:,:) :: TKE_leak_loss_glo_dt + !< energy lost due to misc background processes * dt [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_quad_loss_glo_dt + !< energy lost due to quadratic bottom drag * dt [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_Froude_loss_glo_dt + !< energy lost due to wave breaking [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_itidal_loss_glo_dt + !< energy lost due to small-scale wave drag [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_residual_loss_glo_dt + !< internal tide energy loss due to the residual at slopes [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: error_mode + !< internal tide energy budget error for each mode [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc background processes, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_itidal_loss !< Energy loss rates due to small-scale drag, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_Froude_loss !< Energy loss rates due to wave breaking, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_residual_loss !< Energy loss rates due to residual on slopes, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_allprocesses_loss !< Energy loss rates due to all processes, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:) :: w_struct !< Vertical structure of vertical velocity (normalized) !! for each frequency and each mode [nondim] real, allocatable, dimension(:,:,:,:) :: u_struct !< Vertical structure of horizontal velocity (normalized and @@ -121,7 +146,10 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:) :: int_N2w2 !< Depth-integrated Brunt Vaissalla freqency times !! vertical profile squared, for each mode [H T-2 ~> m s-2 or kg m-2 s-2] real :: q_itides !< fraction of local dissipation [nondim] - real :: En_sum !< global sum of energy for use in debugging, in MKS units [J] + real :: mixing_effic !< mixing efficiency [nondim] + real :: En_sum !< global sum of energy for use in debugging, in MKS units [H Z2 T-2 L2 ~> m5 s-2 or J] + real :: En_underflow !< A minuscule amount of energy [H Z2 T-2 ~> m3 s-2 or J m-2] + integer :: En_restart_power !< A power factor of 2 by which to multiply the energy in restart [nondim] type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. character(len=200) :: inputdir !< directory to look for coastline angle file real :: decay_rate !< A constant rate at which internal tide energy is @@ -130,6 +158,10 @@ module MOM_internal_tides real :: drag_min_depth !< The minimum total ocean thickness that will be used in the denominator !! of the quadratic drag terms for internal tides when !! INTERNAL_TIDE_QUAD_DRAG is true [H ~> m or kg m-2] + real :: gamma_osborn !< Mixing efficiency from Osborn 1980 [nondim] + real :: Kd_min !< The minimum diapycnal diffusivity. [L2 T-1 ~> m2 s-1] + real :: max_TKE_to_Kd !< Maximum allowed value for TKE_to_kd [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: min_thick_layer_Kd !< minimum layer thickness allowed to use with TKE_to_kd [H ~> m] logical :: apply_background_drag !< If true, apply a drag due to background processes as a sink. logical :: apply_bottom_drag @@ -138,30 +170,40 @@ module MOM_internal_tides !< If true, apply scattering due to small-scale roughness as a sink. logical :: apply_Froude_drag !< If true, apply wave breaking as a sink. - real :: En_check_tol !< An energy density tolerance for flagging points with an imbalance in the - !! internal tide energy budget when apply_Froude_drag is True [R Z3 T-2 ~> J m-2] + real :: En_check_tol !< An energy density tolerance for flagging points with small negative + !! internal tide energy [H Z2 T-2 ~> m3 s-2 or J m-2] logical :: apply_residual_drag !< If true, apply sink from residual term of reflection/transmission. real, allocatable :: En(:,:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,frequency,mode) - !! integrated within an angular and frequency band [R Z3 T-2 ~> J m-2] + !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable :: En_ini_glo(:,:) + !< The internal wave energy density as a function of (frequency,mode) + !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + !! only at the start of the routine (for diags) + real, allocatable :: En_end_glo(:,:) + !< The internal wave energy density as a function of (frequency,mode) + !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + !! only at the end of the routine (for diags) real, allocatable :: En_restart_mode1(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 1 [R Z3 T-2 ~> J m-2] + !! for mode 1 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode2(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 2 [R Z3 T-2 ~> J m-2] + !! for mode 2 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode3(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 3 [R Z3 T-2 ~> J m-2] + !! for mode 3 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode4(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 4 [R Z3 T-2 ~> J m-2] + !! for mode 4 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode5(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 5 [R Z3 T-2 ~> J m-2] + !! for mode 5 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. + real :: Int_tide_decay_scale !< vertical decay scale for St Laurent profile [Z ~> m] + real :: Int_tide_decay_scale_slope !< vertical decay scale for St Laurent profile on slopes [Z ~> m] type(wave_speed_CS) :: wave_speed !< Wave speed control structure type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the @@ -236,7 +278,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Local variables real, dimension(SZI_(G),SZJ_(G),CS%nFreq) :: & - TKE_itidal_input, & !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + TKE_itidal_input, & !< The energy input to the internal waves [H Z2 T-3 ~> m3 s-3 or W m-2]. vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),2) :: & @@ -244,30 +286,32 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & cn ! baroclinic internal gravity wave speeds for each mode [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & - tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] + tot_En_mode, & ! energy summed over angles only [H Z2 T-2 ~> m3 s-2 or J m-2] Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & drag_scale ! bottom drag scale [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G)) :: & - tot_vel_btTide2, & - tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] + tot_vel_btTide2, & ! [L2 T-2 ~> m2 s-2] + tot_En, & ! energy summed over angles, modes, frequencies [H Z2 T-2 ~> m3 s-2 or J m-2] tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_residual_loss, tot_allprocesses_loss, & - ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] + ! energy loss rates summed over angle, freq, and mode [H Z2 T-3 ~> m3 s-3 or W m-2] htot, & ! The vertical sum of the layer thicknesses [H ~> m or kg m-2] - itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [R Z3 T-3 ~> W m-2] + itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [H Z2 T-3 ~> m3 s-3 or W m-2] leak_loss_mode, & quad_loss_mode, & Froude_loss_mode, & residual_loss_mode, & allprocesses_loss_mode ! Total energy loss rates for a given mode and frequency (summed over - ! all angles) [R Z3 T-3 ~> W m-2] - + ! all angles) [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] real :: I_D_here ! The inverse of the local water column thickness [H-1 ~> m-1 or m2 kg-1] real :: I_mass ! The inverse of the local water mass [R-1 Z-1 ~> m2 kg-1] + real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: En_restart_factor ! A multiplicative factor of the form 2**En_restart_power [nondim] + real :: I_En_restart_factor ! The inverse of the restart mult factor [nondim] real :: freq2 ! The frequency squared [T-2 ~> s-2] real :: PE_term ! total potential energy of profile [R Z ~> kg m-2] real :: KE_term ! total kinetic energy of profile [R Z ~> kg m-2] @@ -277,10 +321,20 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C real :: loss_rate ! An energy loss rate [T-1 ~> s-1] real :: Fr2_max ! The column maximum internal wave Froude number squared [nondim] real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] - real :: en_subRO ! A tiny energy to prevent division by zero [R Z3 T-2 ~> J m-2] - real :: En_new, En_check ! Energies for debugging [R Z3 T-2 ~> J m-2] - real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] - real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] + real :: en_subRO ! A tiny energy to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_a, En_b ! Energies for time stepping [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_new, En_check ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_sumtmp ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_initial, Delta_E_check ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks + ! [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks + ! [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal + ! [m3 s-3 or W m-2 ~> H Z2 T-3] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal + ! [m3 s-2 or J m-2 ~> H Z2 T-2] character(len=160) :: mesg ! The text of an error message integer :: En_halo_ij_stencil ! The halo size needed for energy advection integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle @@ -292,8 +346,17 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + HZ2_T2_to_J_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**2) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + J_m2_to_HZ2_T2 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + cn_subRO = 1e-30*US%m_s_to_L_T - en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T + en_subRO = 1e-30*J_m2_to_HZ2_T2 + + I_dt = 1.0 / dt + En_restart_factor = 2**CS%En_restart_power + I_En_restart_factor = 1.0 / En_restart_factor ! initialize local arrays TKE_itidal_input(:,:,:) = 0. @@ -307,33 +370,44 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Rebuild energy density array from multiple restarts do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo if (CS%nMode >= 2) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 3) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 4) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 5) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif + if (CS%debug) then + ! save initial energy for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%En(:,:,a,fr,m), G, scale=HZ2_T2_to_J_m2) + enddo + CS%En_ini_glo(fr,m) = En_sumtmp + enddo ; enddo + endif + ! Set properties related to the internal tides, such as the wave speeds, storing some ! of them in the control structure for this module. if (CS%uniform_test_cg > 0.0) then @@ -347,6 +421,19 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! It can be 1 point smaller if teleport is not used. endif + call pass_var(cn,G%Domain) + + if (CS%debug) then + call hchksum(cn(:,:,1), "CN mode 1", G%HI, haloshift=0, scale=US%L_to_m*US%s_to_T) + call hchksum(CS%w_struct(:,:,:,1), "Wstruct mode 1", G%HI, haloshift=0) + call hchksum(CS%u_struct(:,:,:,1), "Ustruct mode 1", G%HI, haloshift=0, scale=US%m_to_Z) + call hchksum(CS%u_struct_bot(:,:,1), "Ustruct_bot mode 1", G%HI, haloshift=0, scale=US%m_to_Z) + call hchksum(CS%u_struct_max(:,:,1), "Ustruct_max mode 1", G%HI, haloshift=0, scale=US%m_to_Z) + call hchksum(CS%int_w2(:,:,1), "int_w2", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(CS%int_U2(:,:,1), "int_U2", G%HI, haloshift=0, scale=GV%H_to_mks*US%m_to_Z**2) + call hchksum(CS%int_N2w2(:,:,1), "int_N2w2", G%HI, haloshift=0, scale=GV%H_to_mks*US%s_to_T**2) + endif + ! Set the wave speeds for the modes, using cg(n) ~ cg(1)/n.********************** ! This is wrong, of course, but it works reasonably in some cases. ! Uncomment if wave_speed is not used to calculate the true values (BDM). @@ -356,62 +443,116 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Add the forcing.*************************************************************** - call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + if (CS%add_tke_forcing) then - if (CS%energized_angle <= 0) then - frac_per_sector = 1.0 / real(CS%nAngle) - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie - f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & - (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) - if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) - enddo ; enddo ; enddo ; enddo ; enddo - elseif (CS%energized_angle <= CS%nAngle) then - frac_per_sector = 1.0 - a = CS%energized_angle - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie - f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & - (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) - if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) - enddo ; enddo ; enddo ; enddo - else - call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& - "band that does not exist.") + call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + + if (CS%debug) then + call hchksum(TKE_itidal_input(:,:,1), "TKE_itidal_input", G%HI, haloshift=0, & + scale=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T)**3) + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides bf input", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + endif + + if (CS%energized_angle <= 0) then + frac_per_sector = 1.0 / real(CS%nAngle) + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) + if (CS%frequency(fr)**2 > f2) then + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + (dt*frac_per_sector*(1.0-CS%q_itides) * & + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr)) + else + ! zero out input TKE value to get correct diagnostics + TKE_itidal_input(i,j,fr) = 0. + endif + enddo ; enddo ; enddo ; enddo ; enddo + elseif (CS%energized_angle <= CS%nAngle) then + frac_per_sector = 1.0 + a = CS%energized_angle + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) + if (CS%frequency(fr)**2 > f2) then + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + (dt*frac_per_sector*(1.0-CS%q_itides) * & + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr)) + else + ! zero out input TKE value to get correct diagnostics + TKE_itidal_input(i,j,fr) = 0. + endif + enddo ; enddo ; enddo ; enddo + else + call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& + "band that does not exist.") + endif + endif ! add tke forcing + + if (CS%init_forcing_only) CS%add_tke_forcing=.false. + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af input", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + ! save forcing for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(dt*frac_per_sector*(1.0-CS%q_itides)* & + CS%fraction_tidal_input(fr,m)*TKE_itidal_input(:,:,fr), & + G, scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_input_glo_dt(fr,m) = En_sumtmp + enddo ; enddo endif ! Pass a test vector to check for grid rotation in the halo updates. do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 1.0 ; test(i,j,2) = 0.0 ; enddo ; enddo - do m=1,CS%nMode ; do fr=1,CS%nFreq - call create_group_pass(pass_En, CS%En(:,:,:,fr,m), G%domain) - enddo ; enddo call create_group_pass(pass_test, test(:,:,1), test(:,:,2), G%domain, stagger=AGRID) call start_group_pass(pass_test, G%domain) + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after forcing') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after forcing', CS%En_sum + enddo ; enddo + endif + ! Apply half the refraction. - do m=1,CS%nMode ; do fr=1,CS%nFreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & - G, US, CS%nAngle, CS%use_PPMang) - enddo ; enddo + if (CS%apply_refraction) then + do m=1,CS%nMode ; do fr=1,CS%nFreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & + G, US, CS%nAngle, CS%use_PPMang) + enddo ; enddo + endif ! A this point, CS%En is only valid on the computational domain. - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif - enddo ; enddo - enddo ; enddo ; enddo + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif - call do_group_pass(pass_En, G%domain) + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 1/2 refraction') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 1/2 refraction', CS%En_sum + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif call complete_group_pass(pass_test, G%domain) @@ -423,52 +564,98 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Rotate points in the halos as necessary. call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo R", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after correct halo rotation') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after correct halo rotation', CS%En_sum + enddo ; enddo + endif + ! Propagate the waves. do m=1,CS%nMode ; do fr=1,CS%Nfreq ! initialize residual loss, will be computed in propagate CS%TKE_residual_loss(:,:,:,fr,m) = 0. + CS%TKE_slope_loss(:,:,:,fr,m) = 0. - call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & - G, US, CS, CS%NAngle, CS%TKE_residual_loss(:,:,:,fr,m)) + if (CS%apply_propagation) then + call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & + G, GV, US, CS, CS%NAngle, CS%TKE_slope_loss(:,:,:,fr,m)) + endif enddo ; enddo - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - if (abs(CS%En(i,j,a,fr,m))>1.0) then ! only print if large - write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 endif - CS%En(i,j,a,fr,m) = 0.0 - endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af prop", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after propagate') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after propagate', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + if (abs(CS%En(i,j,a,fr,m))>CS%En_check_tol) then ! only print if large + write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + ! RD propagate produces very little negative energy (diff 2 large numbers), needs fix + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + endif + enddo ; enddo + enddo ; enddo ; enddo + endif - ! Apply the other half of the refraction. - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & - G, US, CS%NAngle, CS%use_PPMang) - enddo ; enddo - ! A this point, CS%En is only valid on the computational domain. + if (CS%apply_refraction) then + ! Apply the other half of the refraction. + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & + G, US, CS%NAngle, CS%use_PPMang) + enddo ; enddo + ! A this point, CS%En is only valid on the computational domain. + endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr2", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 2/2 refraction') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 2/2 refraction', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Apply various dissipation mechanisms. if (CS%apply_background_drag .or. CS%apply_bottom_drag & @@ -487,25 +674,55 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Extract the energy for mixing due to misc. processes (background leakage)------ if (CS%apply_background_drag) then do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie - ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale - ! to each En component (technically not correct; fix later) - CS%TKE_leak_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * CS%decay_rate ! loss rate [R Z3 T-3 ~> W m-2] - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%decay_rate) ! implicit update + ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale + ! to each En component (technically not correct; fix later) + En_b = CS%En(i,j,a,fr,m) ! save previous value + En_a = CS%En(i,j,a,fr,m) / (1.0 + (dt * CS%decay_rate)) ! implicit update + CS%TKE_leak_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt ! compute exact loss rate [H Z2 T-3 ~> m3 s-3 or W m-2] + CS%En(i,j,a,fr,m) = En_a ! update value enddo ; enddo ; enddo ; enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after leak", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after background drag') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after background drag', CS%En_sum + call sum_En(G, GV, US, CS, CS%TKE_leak_loss(:,:,:,fr,m) * dt, 'prop_int_tide: loss after background drag') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: loss after background drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_leak_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_leak_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + endif ! Extract the energy for mixing due to bottom drag------------------------------- if (CS%apply_bottom_drag) then @@ -514,7 +731,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call get_barotropic_tidal_vel(G, vel_btTide, CS%nFreq, inttide_input_CSp) do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied - tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + vel_btTide(i,j,fr)**2 + tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + (vel_btTide(i,j,fr)**2) enddo ; enddo ; enddo do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied @@ -524,38 +741,66 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) - drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & - tot_En_mode(i,j,fr,m) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here + drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j) + & + (tot_En_mode(i,j,fr,m) * I_D_here))) * GV%Z_to_H*I_D_here enddo ; enddo ; enddo ; enddo else do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied - I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) + I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) + I_mass = GV%RZ_to_H * I_D_here drag_scale(i,j,fr,m) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & - sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & - tot_En_mode(i,j,fr,m) * I_mass)) + sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j) + & + (tot_En_mode(i,j,fr,m) * I_D_here))) enddo ; enddo ; enddo ; enddo endif + + if (CS%debug) call hchksum(drag_scale(:,:,1,1), "dragscale", G%HI, haloshift=0, scale=US%s_to_T) + if (CS%debug) call hchksum(tot_vel_btTide2(:,:), "tot_vel_btTide2", G%HI, haloshift=0, scale=US%L_T_to_m_s**2) + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) - CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j,fr,m) ! loss rate - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j,fr,m)) ! implicit update + En_b = CS%En(i,j,a,fr,m) + En_a = CS%En(i,j,a,fr,m) / (1.0 + (dt * drag_scale(i,j,fr,m))) ! implicit update + CS%TKE_quad_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a enddo ; enddo ; enddo ; enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - !stop - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after quad", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_quad_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_quad_loss_glo_dt(fr,m) = En_sumtmp enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Extract the energy for mixing due to scattering (wave-drag)-------------------- ! still need to allow a portion of the extracted energy to go to higher modes. @@ -572,18 +817,18 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C f2 = (0.25*(G%CoriolisBu(I,J) + G%CoriolisBu(max(I-1,1),max(J-1,1)) + & G%CoriolisBu(I,max(J-1,1)) + G%CoriolisBu(max(I-1,1),J)))**2 - Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) + Kmag2 = (freq2 - f2) / ((cn(i,j,m)**2) + (cn_subRO**2)) ! Back-calculate amplitude from energy equation if ( (G%mask2dT(i,j) > 0.5) .and. (freq2*Kmag2 > 0.0)) then ! Units here are [R Z ~> kg m-2] - KE_term = 0.25*GV%H_to_RZ*( ((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m) + & + KE_term = 0.25*GV%H_to_RZ*( (((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m)) + & CS%int_w2(i,j,m) ) PE_term = 0.25*GV%H_to_RZ*( CS%int_N2w2(i,j,m) / freq2 ) if (KE_term + PE_term > 0.0) then - W0 = sqrt( tot_En_mode(i,j,fr,m) / (KE_term + PE_term) ) + W0 = sqrt( GV%H_to_RZ * tot_En_mode(i,j,fr,m) / (KE_term + PE_term) ) else !call MOM_error(WARNING, "MOM internal tides: KE + PE <= 0.0; setting to W0 to 0.0") W0 = 0.0 @@ -608,19 +853,45 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, CS%En, CS%TKE_itidal_loss_fixed, & CS%TKE_itidal_loss, dt, halo_size=0) endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after wave", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: before Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: before Froude drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! save loss term for online budget, may want to add a debug flag later + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_itidal_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_itidal_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Extract the energy for mixing due to wave breaking----------------------------- if (CS%apply_Froude_drag) then @@ -632,85 +903,131 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Calculate horizontal phase velocity magnitudes f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) - Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) + Kmag2 = (freq2 - f2) / ((cn(i,j,m)**2) + (cn_subRO**2)) c_phase = 0.0 + CS%TKE_Froude_loss(i,j,:,fr,m) = 0. ! init for all angles if (Kmag2 > 0.0) then c_phase = sqrt(freq2/Kmag2) Fr2_max = (Umax(i,j,fr,m) / c_phase)**2 ! Dissipate energy if Fr>1; done here with an arbitrary time scale if (Fr2_max > 1.0) then - En_initial = sum(CS%En(i,j,:,fr,m)) ! for debugging ! Calculate effective decay rate [T-1 ~> s-1] if breaking occurs over a time step - loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) + !loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) do a=1,CS%nAngle ! Determine effective dissipation rate (Wm-2) - CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) - ! Update energy - En_new = CS%En(i,j,a,fr,m)/Fr2_max ! for debugging - En_check = CS%En(i,j,a,fr,m) - CS%TKE_Froude_loss(i,j,a,fr,m)*dt ! for debugging - ! Re-scale (reduce) energy due to breaking - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m)/Fr2_max - ! Check (for debugging only) - if (abs(En_new - En_check) > CS%En_check_tol) then - call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr-breaking.", & - all_print=.true.) - write(mesg,*) "En_new=", En_new , "En_check=", En_check - call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) - endif + !CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) + En_b = CS%En(i,j,a,fr,m) + En_a = CS%En(i,j,a,fr,m)/Fr2_max + CS%TKE_Froude_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a enddo - ! Check (for debugging) - Delta_E_check = En_initial - sum(CS%En(i,j,:,fr,m)) - TKE_Froude_loss_check = abs(Delta_E_check)/dt - TKE_Froude_loss_tot = sum(CS%TKE_Froude_loss(i,j,:,fr,m)) - if (abs(TKE_Froude_loss_check - TKE_Froude_loss_tot)*dt > CS%En_check_tol) then - call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr energy update.", & - all_print=.true.) - write(mesg,*) "TKE_Froude_loss_check=", TKE_Froude_loss_check, & - "TKE_Froude_loss_tot=", TKE_Froude_loss_tot - call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) - endif endif ! Fr2>1 endif ! Kmag2>0 CS%cp(i,j,fr,m) = c_phase enddo ; enddo enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - write(mesg,*) 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - !stop - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after froude", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after Froude drag', CS%En_sum + call sum_En(G, GV, US, CS, CS%TKE_Froude_loss(:,:,:,fr,m) * dt, 'prop_int_tide: loss after Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: loss after Froude drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! save loss term for online budget, may want to add a debug flag later + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_Froude_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_Froude_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + write(mesg,*) 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! loss from residual of reflection/transmission coefficients if (CS%apply_residual_drag) then do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie - ! implicit form + ! implicit form is rewritten to minimize number of divisions !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%TKE_residual_loss(i,j,a,fr,m) / & ! (CS%En(i,j,a,fr,m) + en_subRO)) - ! rewritten to minimize number of divisions: - CS%En(i,j,a,fr,m) = (CS%En(i,j,a,fr,m) * (CS%En(i,j,a,fr,m) + en_subRO)) / & - ((CS%En(i,j,a,fr,m) + en_subRO) + dt * CS%TKE_residual_loss(i,j,a,fr,m)) + ! only compute when partial reflection is present not to create noise elsewhere + if (CS%refl_pref_logical(i,j)) then + En_b = CS%En(i,j,a,fr,m) + En_a = (CS%En(i,j,a,fr,m) * (CS%En(i,j,a,fr,m) + en_subRO)) / & + ((CS%En(i,j,a,fr,m) + en_subRO) + (dt * CS%TKE_slope_loss(i,j,a,fr,m))) + CS%TKE_residual_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a + endif + enddo ; enddo ; enddo ; enddo ; enddo - ! explicit form - !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) - dt * CS%TKE_residual_loss(i,j,a,fr,m) + else + ! zero out the residual loss term so it does not count towards diagnostics + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + CS%TKE_residual_loss(i,j,a,fr,m) = 0. enddo ; enddo ; enddo ; enddo ; enddo endif + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after slope", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') + enddo ; enddo + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_residual_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_residual_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + endif - ! Check for energy conservation on computational domain.************************* - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call sum_En(G, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') - enddo ; enddo + !---- energy budget ---- + if (CS%debug) then + ! save final energy for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%En(:,:,a,fr,m), G, scale=HZ2_T2_to_J_m2) + enddo + CS%En_end_glo(fr,m) = En_sumtmp + enddo ; enddo + + do m=1,CS%nMode ; do fr=1,CS%nFreq + CS%error_mode(fr,m) = CS%En_ini_glo(fr,m) + CS%TKE_input_glo_dt(fr,m) - CS%TKE_leak_loss_glo_dt(fr,m) - & + CS%TKE_quad_loss_glo_dt(fr,m) - CS%TKE_itidal_loss_glo_dt(fr,m) - & + CS%TKE_Froude_loss_glo_dt(fr,m) - CS%TKE_residual_loss_glo_dt(fr,m) - & + CS%En_end_glo(fr,m) + if (is_root_pe()) write(stdout,'(A,F18.10)') "error in Energy budget", CS%error_mode(fr,m) + enddo ; enddo + endif ! Output diagnostics.************************************************************ avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) @@ -743,30 +1060,30 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! split energy array into multiple restarts do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode1(i,j,a,fr) = CS%En(i,j,a,fr,1) + CS%En_restart_mode1(i,j,a,fr) = CS%En(i,j,a,fr,1) * En_restart_factor enddo ; enddo ; enddo ; enddo if (CS%nMode >= 2) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode2(i,j,a,fr) = CS%En(i,j,a,fr,2) + CS%En_restart_mode2(i,j,a,fr) = CS%En(i,j,a,fr,2) * En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 3) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode3(i,j,a,fr) = CS%En(i,j,a,fr,3) + CS%En_restart_mode3(i,j,a,fr) = CS%En(i,j,a,fr,3) * En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 4) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode4(i,j,a,fr) = CS%En(i,j,a,fr,4) + CS%En_restart_mode4(i,j,a,fr) = CS%En(i,j,a,fr,4) * En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 5) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode5(i,j,a,fr) = CS%En(i,j,a,fr,5) + CS%En_restart_mode5(i,j,a,fr) = CS%En(i,j,a,fr,5) * En_restart_factor enddo ; enddo ; enddo ; enddo endif @@ -889,12 +1206,13 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C end subroutine propagate_int_tide !> Checks for energy conservation on computational domain -subroutine sum_En(G, US, CS, En, label) +subroutine sum_En(G, GV, US, CS, En, label) 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(int_tide_CS), intent(inout) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), & - intent(in) :: En !< The energy density of the internal tides [R Z3 T-2 ~> J m-2]. + intent(in) :: En !< The energy density of the internal tides [H Z2 T-2 ~> m3 s-2 or J m-2]. character(len=*), intent(in) :: label !< A label to use in error messages ! Local variables real :: En_sum ! The total energy in MKS units for potential output [J] @@ -906,7 +1224,7 @@ subroutine sum_En(G, US, CS, En, label) En_sum = 0.0 do a=1,CS%nAngle - En_sum = En_sum + global_area_integral(En(:,:,a), G, scale=US%RZ3_T3_to_W_m2*US%T_to_s) + En_sum = En_sum + global_area_integral(En(:,:,a), G, unscale=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T)**2) enddo CS%En_sum = En_sum !En_sum_diff = En_sum - CS%En_sum @@ -945,32 +1263,49 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R Z4 H-1 L-2 ~> kg m-2 or m] !! (rho*kappa*h^2) or (kappa*h^2). real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(inout) :: En !< Energy density of the internal waves [R Z3 T-2 ~> J m-2]. + intent(inout) :: En !< Energy density of the internal waves [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(out) :: TKE_loss !< Energy loss rate [R Z3 T-3 ~> W m-2] + intent(out) :: TKE_loss !< Energy loss rate [H Z2 T-3 ~> m3 s-3 or W m-2] !! (q*rho*kappa*h^2*N*U^2). real, intent(in) :: dt !< Time increment [T ~> s]. integer, optional, intent(in) :: halo_size !< The halo size over which to do the calculations ! Local variables integer :: j, i, m, fr, a, is, ie, js, je, halo - real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] - real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] + real :: En_tot ! energy for a given mode, frequency + ! and point summed over angles [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: TKE_loss_tot ! dissipation for a given mode, frequency + ! and point summed over angles [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_per_sector ! fraction of energy in each wedge [nondim] real :: q_itides ! fraction of energy actually lost to mixing (remainder, 1-q, is ! assumed to stay in propagating mode for now - BDM) [nondim] real :: loss_rate ! approximate loss rate for implicit calc [T-1 ~> s-1] - real :: En_negl ! negligibly small number to prevent division by zero [R Z3 T-2 ~> J m-2] + real :: En_negl ! negligibly small number to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_a, En_b ! energy before and after timestep [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal [m3 s-2 or J m-2 ~> H Z2 T-2] + real :: HZ2_T3_to_W_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + J_m2_to_HZ2_T2 = GV%m_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + HZ2_T3_to_W_m2 = GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3) + + I_dt = 1.0 / dt q_itides = CS%q_itides - En_negl = 1e-30*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2 + En_negl = 1e-30*J_m2_to_HZ2_T2 if (present(halo_size)) then halo = halo_size is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo endif + if (CS%debug) then + call hchksum(TKE_loss_fixed, "TKE loss fixed", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2*(US%Z_to_m**3)*GV%m_to_H*(US%m_to_L**2)) + call hchksum(Nb(:,:), "Nbottom", G%HI, haloshift=0, scale=US%s_to_T) + call hchksum(Ub(:,:,1,1), "Ubottom", G%HI, haloshift=0, scale=US%L_to_m*US%s_to_T) + endif + do j=js,je ; do i=is,ie ; do m=1,CS%nMode ; do fr=1,CS%nFreq ! Sum energy across angles @@ -979,11 +1314,11 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe En_tot = En_tot + En(i,j,a,fr,m) enddo - ! Calculate TKE loss rate; units of [R Z3 T-3 ~> W m-2] here. + ! Calculate TKE loss rate; units of [H Z2 T-3 ~> m3 s-3 or W m-2] here. if (GV%Boussinesq .or. GV%semi_Boussinesq) then - TKE_loss_tot = q_itides * GV%Z_to_H * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + TKE_loss_tot = q_itides * GV%RZ_to_H*GV%Z_to_H*TKE_loss_fixed(i,j)*Nb(i,j)*Ub(i,j,fr,m)**2 else - TKE_loss_tot = q_itides * (GV%RZ_to_H * Rho_bot(i,j)) * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + TKE_loss_tot = q_itides * (GV%RZ_to_H*GV%RZ_to_H*Rho_bot(i,j))*TKE_loss_fixed(i,j)*Nb(i,j)*Ub(i,j,fr,m)**2 endif ! Update energy remaining (this is a pseudo implicit calc) @@ -991,9 +1326,12 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe if (En_tot > 0.0) then do a=1,CS%nAngle frac_per_sector = En(i,j,a,fr,m)/En_tot - TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [R Z3 T-3 ~> W m-2] + TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [H Z2 T-3 ~> m3 s-3 or W m-2] loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! [T-1 ~> s-1] - En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt*loss_rate) + En_b = En(i,j,a,fr,m) + En_a = En(i,j,a,fr,m) / (1.0 + (dt*loss_rate)) + TKE_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt ! overwrite with exact value + En(i,j,a,fr,m) = En_a enddo else ! no loss if no energy @@ -1002,24 +1340,6 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe enddo endif - ! Update energy remaining (this is the old explicit calc) - !if (En_tot > 0.0) then - ! do a=1,CS%nAngle - ! frac_per_sector = En(i,j,a,fr,m)/En_tot - ! TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot - ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then - ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt - ! else - ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than available, "// & - ! " setting En to zero.", all_print=.true.) - ! En(i,j,a,fr,m) = 0.0 - ! endif - ! enddo - !else - ! ! no loss if no energy - ! TKE_loss(i,j,:,fr,m) = 0.0 - !endif - enddo ; enddo ; enddo ; enddo end subroutine itidal_lowmode_loss @@ -1035,15 +1355,451 @@ subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) type(int_tide_CS), intent(in) :: CS !< Internal tide control structure character(len=*), intent(in) :: mechanism !< The named mechanism of loss to return real, intent(out) :: TKE_loss_sum !< Total energy loss rate due to specified - !! mechanism [R Z3 T-3 ~> W m-2]. + !! mechanism [H Z2 T-3 ~> m3 s-3 or W m-2]. - if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet - if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet - if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing - if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet + if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) + if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) + if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) + if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) + if (mechanism == 'SlopeDrag') TKE_loss_sum = CS%tot_residual_loss(i,j) end subroutine get_lowmode_loss + +!> Returns the values of diffusivity corresponding to various mechanisms +subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2_int, TKE_to_Kd, Kd_max, CS, & + Kd_leak, Kd_quad, Kd_itidal, Kd_Froude, Kd_slope, & + Kd_lay, Kd_int, profile_leak, profile_quad, profile_itidal, & + profile_Froude, profile_slope) + + 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 thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G)), intent(in) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G)), intent(in) :: k_bot !< Bottom boundary layer top layer index + integer, intent(in) :: j !< The j-index to work on + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + !! layers [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy frequency of the + !! interfaces [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + !! dissipated within a layer and the + !! diapycnal diffusivity within that layer, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] + real, intent(in) :: Kd_max !< The maximum increment for diapycnal + !! diffusivity due to TKE-based processes + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + !! Set this to a negative value to have no limit. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + type(int_tide_cs), intent(in) :: CS !< The control structure for this module + + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_leak !< Diffusivity due to background drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_quad !< Diffusivity due to bottom drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_itidal !< Diffusivity due to wave drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_Froude !< Diffusivity due to high Froude breaking + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_slope !< Diffusivity due to critical slopes + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_leak !< Normalized profile for background drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_quad !< Normalized profile for bottom drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_itidal !< Normalized profile for wave drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_Froude !< Normalized profile for Froude drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_slope !< Normalized profile for critical slopes + !! [H-1 ~> m-1] + + ! local variables + real :: TKE_loss ! temp variable to pass value of internal tides TKE loss [R Z-3 T-3 ~> W/m2] + real :: renorm_N ! renormalization for N profile [H T-1 ~> m s-1] + real :: renorm_N2 ! renormalization for N2 profile [H T-2 ~> m s-2] + real :: tmp_StLau ! tmp var for renormalization for StLaurent profile [nondim] + real :: tmp_StLau_slope ! tmp var for renormalization for StLaurent profile [nondim] + real :: renorm_StLau ! renormalization for StLaurent profile [nondim] + real :: renorm_StLau_slope! renormalization for StLaurent profile [nondim] + real :: htot ! total depth of water column [H ~> m] + real :: htmp ! local value of thickness in layers [H ~> m] + real :: h_d ! expomential decay length scale [H ~> m] + real :: h_s ! expomential decay length scale on the slope [H ~> m] + real :: I_h_d ! inverse of expomential decay length scale [H-1 ~> m-1] + real :: I_h_s ! inverse of expomential decay length scale on the slope [H-1 ~> m-1] + real :: TKE_to_Kd_lim ! limited version of TKE_to_Kd [T2 Z-1 ~> s2 m-1] + + ! vertical profiles have units Z-1 for conversion to Kd to be dim correct (see eq 2 of St Laurent GRL 2002) + real, dimension(SZK_(GV)) :: profile_N ! vertical profile varying with N [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_N2 ! vertical profile varying with N2 [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_StLaurent ! vertical profile according to St Laurent 2002 [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_StLaurent_slope ! vertical profile according to St Laurent 2002 [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_BBL ! vertical profile Heavyside BBL [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: Kd_leak_lay ! Diffusivity due to background drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_quad_lay ! Diffusivity due to bottom drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_itidal_lay ! Diffusivity due to wave drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_Froude_lay ! Diffusivity due to high Froude breaking [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_slope_lay ! Diffusivity due to critical slopes [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + real :: hmin ! A minimum allowable thickness [H ~> m] + real :: h_rmn ! Remaining thickness in k-loop [H ~> m] + real :: frac ! A fraction of thicknesses [nondim] + real :: verif_N, & ! profile verification [nondim] + verif_N2, & ! profile verification [nondim] + verif_bbl, & ! profile verification [nondim] + verif_stl1,& ! profile verification [nondim] + verif_stl2,& ! profile verification [nondim] + threshold_renorm_N2,& ! Maximum allowable error on N2 profile [H T-2 ~> m.s-2] + threshold_renorm_N, & ! Maximum allowable error on N profile [H T-1 ~> m.s-1] + threshold_verif ! Maximum allowable error on verification [nondim] + + logical :: non_Bous ! fully Non-Boussinesq + integer :: i, k, is, ie, nz + + is=G%isc ; ie=G%iec ; nz=GV%ke + + non_Bous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + + h_d = CS%Int_tide_decay_scale + h_s = CS%Int_tide_decay_scale_slope + I_h_d = 1 / h_d + I_h_s = 1 / h_s + + hmin = 1.0e-6*GV%m_to_H + threshold_renorm_N2 = 1.0e-13 * GV%m_to_H * US%T_to_s**2 + threshold_renorm_N = 1.0e-13 * GV%m_to_H * US%T_to_s + threshold_verif = 1.0e-13 + + ! init output arrays + profile_leak(:,:) = 0.0 + profile_quad(:,:) = 0.0 + profile_slope(:,:) = 0.0 + profile_itidal(:,:) = 0.0 + profile_Froude(:,:) = 0.0 + + Kd_leak_lay(:) = 0.0 + Kd_quad_lay(:) = 0.0 + Kd_itidal_lay(:) = 0.0 + Kd_Froude_lay(:) = 0.0 + Kd_slope_lay(:) = 0.0 + + Kd_leak(:,:) = 0.0 + Kd_quad(:,:) = 0.0 + Kd_itidal(:,:) = 0.0 + Kd_Froude(:,:) = 0.0 + Kd_slope(:,:) = 0.0 + + do i=is,ie + + ! create vertical profiles for diffusivites in layers + renorm_N = 0.0 + renorm_N2 = 0.0 + renorm_StLau = 0.0 + renorm_StLau_slope = 0.0 + tmp_StLau = 0.0 + tmp_StLau_slope = 0.0 + htot = 0.0 + htmp = 0.0 + + do k=1,nz + ! N-profile + if (N2_lay(i,k) < 0.) call MOM_error(WARNING, "negative buoyancy freq") + renorm_N = renorm_N + (sqrt(max(N2_lay(i,k), 0.)) * h(i,j,k)) + ! N2-profile + renorm_N2 = renorm_N2 + (max(N2_lay(i,k), 0.) * h(i,j,k)) + ! total depth + htot = htot + h(i,j,k) + enddo + + profile_N2(:) = 0.0 + profile_N(:) = 0.0 + profile_BBL(:) = 0.0 + profile_StLaurent(:) = 0.0 + profile_StLaurent_slope(:) = 0.0 + + ! BBL-profile + h_rmn = h_bot(i) + do k=nz,1,-1 + if (G%mask2dT(i,j) > 0.0) then + profile_BBL(k) = 0.0 + if (h(i,j,k) <= h_rmn) then + profile_BBL(k) = 1.0 / h_bot(i) + h_rmn = h_rmn - h(i,j,k) + else + if (h_rmn > 0.0) then + frac = h_rmn / h(i,j,k) + profile_BBL(k) = frac / h_bot(i) + h_rmn = h_rmn - frac*h(i,j,k) + endif + endif + endif + enddo + + do k=1,nz + if (G%mask2dT(i,j) > 0.0) then + ! N - profile + if (renorm_N > threshold_renorm_N) then + profile_N(k) = sqrt(max(N2_lay(i,k), 0.)) / renorm_N + else + profile_N(k) = 1 / htot + endif + + ! N2 - profile + if (renorm_N2 > threshold_renorm_N2) then + profile_N2(k) = max(N2_lay(i,k), 0.) / renorm_N2 + else + profile_N2(k) = 1 / htot + endif + + ! slope intensified (St Laurent GRL 2002) - profile + ! in paper, z is defined positive upwards, range 0 to -H + ! here depth positive downwards + ! profiles are almost normalized but differ from a few percent + ! so we add a second renormalization factor + + ! add first half of layer: get to the layer center + htmp = htmp + 0.5*h(i,j,k) + + profile_StLaurent(k) = exp(-I_h_d*(htot-htmp)) / & + (h_d*(1 - exp(-I_h_d*htot))) + + profile_StLaurent_slope(k) = exp(-I_h_s*(htot-htmp)) / & + (h_s*(1 - exp(-I_h_s*htot))) + + tmp_StLau = tmp_StLau + (profile_StLaurent(k) * h(i,j,k)) + tmp_StLau_slope = tmp_StLau_slope + (profile_StLaurent_slope(k) * h(i,j,k)) + + ! add second half of layer: get to the next interface + htmp = htmp + 0.5*h(i,j,k) + endif + enddo + + if (G%mask2dT(i,j) > 0.0) then + ! allow for difference less than verification threshold + renorm_StLau = 1.0 + renorm_StLau_slope = 1.0 + if (abs(tmp_StLau -1.0) > threshold_verif) renorm_StLau = 1.0 / tmp_StLau + if (abs(tmp_StLau_slope -1.0) > threshold_verif) renorm_StLau_slope = 1.0 / tmp_StLau_slope + + do k=1,nz + profile_StLaurent(k) = profile_StLaurent(k) * renorm_StLau + profile_StLaurent_slope(k) = profile_StLaurent_slope(k) * renorm_StLau_slope + enddo + endif + + ! verif integrals + if (CS%debug) then + if (G%mask2dT(i,j) > 0.0) then + verif_N = 0.0 + verif_N2 = 0.0 + verif_bbl = 0.0 + verif_stl1 = 0.0 + verif_stl2 = 0.0 + do k=1,nz + verif_N = verif_N + (profile_N(k) * h(i,j,k)) + verif_N2 = verif_N2 + (profile_N2(k) * h(i,j,k)) + verif_bbl = verif_bbl + (profile_BBL(k) * h(i,j,k)) + verif_stl1 = verif_stl1 + (profile_StLaurent(k) * h(i,j,k)) + verif_stl2 = verif_stl2 + (profile_StLaurent_slope(k) * h(i,j,k)) + enddo + + if (abs(verif_N -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)') i, j, verif_N + call MOM_error(FATAL, "mismatch integral for N profile") + endif + if (abs(verif_N2 -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)') i, j, verif_N2 + call MOM_error(FATAL, "mismatch integral for N2 profile") + endif + if (abs(verif_bbl -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)') i, j, verif_bbl + call MOM_error(FATAL, "mismatch integral for bbl profile") + endif + if (abs(verif_stl1 -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)') i, j, verif_stl1 + call MOM_error(FATAL, "mismatch integral for stl1 profile") + endif + if (abs(verif_stl2 -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)') i, j, verif_stl2 + call MOM_error(FATAL, "mismatch integral for stl2 profile") + endif + + endif + endif + + ! note on units: TKE_to_Kd = 1 / ((g/rho0) * drho) Z-1 T2 + ! mult by dz gives -1/N2 in T2 + + ! get TKE loss value and compute diffusivites in layers + if (CS%apply_background_drag) then + call get_lowmode_loss(i, j, G, CS, "LeakDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%leak_profile) == "N2" then + profile_leak(i,:) = profile_N2(:) + ! elseif trim(CS%leak_profile) == "N" then + ! profile_leak(:) = profile_N(:) + ! something else + ! endif + Kd_leak_lay(:) = 0. + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_leak_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_leak(i,k) * h(i,j,k) + else + Kd_leak_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_leak_lay(k), Kd_max) + enddo + endif + + if (CS%apply_Froude_drag) then + call get_lowmode_loss(i, j, G, CS, "Froude", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%Froude_profile) == "N" then + profile_Froude(i,:) = profile_N(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_Froude(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_Froude_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_Froude(i,k) * h(i,j,k) + else + Kd_Froude_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_Froude_lay(k), Kd_max) + enddo + endif + + if (CS%apply_wave_drag) then + call get_lowmode_loss(i, j, G, CS, "WaveDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%wave_profile) == "StLaurent" then + profile_itidal(i,:) = profile_StLaurent(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_itidal(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_itidal_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_itidal(i,k) * h(i,j,k) + else + Kd_itidal_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_itidal_lay(k), Kd_max) + enddo + endif + + if (CS%apply_residual_drag) then + call get_lowmode_loss(i, j, G, CS, "SlopeDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%wave_profile) == "StLaurent" then + profile_slope(i,:) = profile_StLaurent_slope(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_itidal(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_slope_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_slope(i,k) * h(i,j,k) + else + Kd_slope_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_slope_lay(k), Kd_max) + enddo + endif + + if (CS%apply_bottom_drag) then + call get_lowmode_loss(i, j, G, CS, "QuadDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%bottom_profile) == "BBL" then + profile_quad(i,:) = profile_BBL(:) + ! elseif trim(CS%bottom_profile) == "N2" then + ! profile_quad(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_quad_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_quad(i,k) * h(i,j,k) + else + Kd_quad_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_quad_lay(k), Kd_max) + enddo + endif + + ! interpolate Kd_[] to interfaces and add to Kd_int + if (CS%apply_background_drag) then + do k=1,nz+1 + if (k>1) Kd_leak(i,K) = 0.5*Kd_leak_lay(k-1) + if (k1) Kd_itidal(i,K) = 0.5*Kd_itidal_lay(k-1) + if (k1) Kd_Froude(i,K) = 0.5*Kd_Froude_lay(k-1) + if (k1) Kd_slope(i,K) = 0.5*Kd_slope_lay(k-1) + if (k1) Kd_quad(i,K) = 0.5*Kd_quad_lay(k-1) + if (k Implements refraction on the internal waves at a single frequency. subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -1052,7 +1808,7 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution, - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. @@ -1063,13 +1819,14 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) ! Local variables integer, parameter :: stencil = 2 real, dimension(SZI_(G),1-stencil:NAngle+stencil) :: & - En2d ! The internal gravity wave energy density in zonal slices [R Z3 T-2 ~> J m-2] + En2d ! The internal gravity wave energy density in zonal slices [H Z2 T-2 ~> m3 s-2 or J m-2] real, dimension(1-stencil:NAngle+stencil) :: & cos_angle, sin_angle ! The cosine and sine of each angle [nondim] real, dimension(SZI_(G)) :: & Dk_Dt_Kmag, Dl_Dt_Kmag ! Rates of angular refraction [T-1 ~> s-1] real, dimension(SZI_(G),0:nAngle) :: & - Flux_E ! The flux of energy between successive angular wedges within a timestep [R Z3 T-2 ~> J m-2] + Flux_E ! The flux of energy between successive angular wedges + ! within a timestep [H Z2 T-2 ~> m3 s-2 or J m-2] real, dimension(SZI_(G),SZJ_(G),1-stencil:NAngle+stencil) :: & CFL_ang ! The CFL number of angular refraction [nondim] real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: cn_u !< Internal wave group velocity at U-point [L T-1 ~> m s-1] @@ -1096,18 +1853,18 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) cnmask(:,:) = merge(0., 1., cn(:,:) == 0.) - do j=js,je ; do i=is-1,ie + do j=js,je ; do I=is-1,ie ! wgt = 0 if local cn == 0, wgt = 0.5 if both contiguous values != 0 ! and wgt = 1 if neighbour cn == 0 - wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) - wgt2 = cnmask(i+1,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) - cn_u(I,j) = wgt1*cn(i,j) + wgt2*cn(i+1,j) + wgt1 = cnmask(i,j) - (0.5 * cnmask(i,j) * cnmask(i+1,j)) + wgt2 = cnmask(i+1,j) - (0.5 * cnmask(i,j) * cnmask(i+1,j)) + cn_u(I,j) = (wgt1*cn(i,j)) + (wgt2*cn(i+1,j)) enddo ; enddo - do j=js-1,je ; do i=is,ie - wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i,j+1) - wgt2 = cnmask(i,j+1) - 0.5 * cnmask(i,j) * cnmask(i,j+1) - cn_v(i,J) = wgt1*cn(i,j) + wgt2*cn(i,j+1) + do J=js-1,je ; do i=is,ie + wgt1 = cnmask(i,j) - (0.5 * cnmask(i,j) * cnmask(i,j+1)) + wgt2 = cnmask(i,j+1) - (0.5 * cnmask(i,j) * cnmask(i,j+1)) + cn_v(i,J) = (wgt1*cn(i,j)) + (wgt2*cn(i,j+1)) enddo ; enddo Ifreq = 1.0 / freq @@ -1138,10 +1895,10 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) (G%Coriolis2Bu(I,J-1) + G%Coriolis2Bu(I-1,J))) favg = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J))) - df_dx = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) - & - (G%CoriolisBu(I-1,J) + G%CoriolisBu(I-1,J-1))) * G%IdxT(i,j) - df_dy = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) - & - (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J-1))) * G%IdyT(i,j) + df_dx = 0.5*G%IdxT(i,j)*((G%CoriolisBu(I,J) - G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I,J-1) - G%CoriolisBu(I-1,J))) + df_dy = 0.5*G%IdyT(i,j)*((G%CoriolisBu(I,J) - G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I-1,J) - G%CoriolisBu(I,J-1))) dlnCn_dx = G%IdxT(i,j) * (cn_u(I,j) - cn_u(I-1,j)) / (0.5 * (cn_u(I,j) + cn_u(I-1,j)) + cn_subRO) dlnCn_dy = G%IdyT(i,j) * (cn_v(i,J) - cn_v(i,J-1)) / (0.5 * (cn_v(i,J) + cn_v(i,J-1)) + cn_subRO) @@ -1159,10 +1916,10 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) ! Determine the energy fluxes in angular orientation space. do A=asd,aed ; do i=is,ie - CFL_ang(i,j,A) = (cos_angle(A) * Dl_Dt_Kmag(i) - sin_angle(A) * Dk_Dt_Kmag(i)) * dt_Angle_size + CFL_ang(i,j,A) = ((cos_angle(A) * Dl_Dt_Kmag(i)) - (sin_angle(A) * Dk_Dt_Kmag(i))) * dt_Angle_size if (abs(CFL_ang(i,j,A)) > 1.0) then call MOM_error(WARNING, "refract: CFL exceeds 1.", .true.) - if (CFL_ang(i,j,A) > 0.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif + if (CFL_ang(i,j,A) > 1.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif endif enddo ; enddo @@ -1202,25 +1959,25 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) integer, intent(in) :: halo_ang !< The halo size in angular space real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: En2d !< The internal gravity wave energy density as a - !! function of angular resolution [R Z3 T-2 ~> J m-2]. + !! function of angular resolution [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: CFL_ang !< The CFL number of the energy advection across angles [nondim] real, dimension(0:NAngle), intent(out) :: Flux_En !< The time integrated internal wave energy flux - !! across angles [R Z3 T-2 ~> J m-2]. + !! across angles [H Z2 T-2 ~> m3 s-2 or J m-2]. ! Local variables - real :: flux ! The internal wave energy flux across angles [R Z3 T-3 ~> W m-2]. + real :: flux ! The internal wave energy flux across angles [H Z2 T-3 ~> m3 s-3 or W m-2]. real :: u_ang ! Angular propagation speed [Rad T-1 ~> Rad s-1] real :: Angle_size ! The size of each orientation wedge in radians [Rad] real :: I_Angle_size ! The inverse of the orientation wedges [Rad-1] real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] - real :: aR, aL ! Left and right edge estimates of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] + real :: aR, aL ! Left and right edge estimates of energy density [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] real :: Ep, Ec, Em ! Mean angular energy density for three successive wedges in angular - ! orientation [R Z3 T-2 rad-1 ~> J m-2 rad-1] - real :: dA, curv_3 ! Difference and curvature of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] + ! orientation [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] + real :: dA, curv_3 ! Difference and curvature of energy density [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] real, parameter :: oneSixth = 1.0/6.0 ! One sixth [nondim] integer :: a - I_dt = 1 / dt + I_dt = 1.0 / dt Angle_size = (8.0*atan(1.0)) / (real(NAngle)) I_Angle_size = 1 / Angle_size Flux_En(:) = 0 @@ -1230,7 +1987,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) if (u_ang >= 0.0) then ! Implementation of PPM-H3 ! Convert wedge-integrated energy density into angular energy densities for three successive - ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + ! wedges around the source wedge for this flux [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1]. Ep = En2d(a+1)*I_Angle_size Ec = En2d(a) *I_Angle_size Em = En2d(a-1)*I_Angle_size @@ -1248,15 +2005,15 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge endif curv_3 = (aR + aL) - 2.0*Ec ! Curvature - ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + ! Calculate angular flux rate [H Z2 T-3 ~> m3 s-3 or W m-2] flux = u_ang*( aR + CFL_ang(A) * ( 0.5*(aL - aR) + curv_3 * (CFL_ang(A) - 1.5) ) ) - ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] + ! Calculate amount of energy fluxed between wedges [H Z2 T-2 ~> m3 s-2 or J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux else ! Implementation of PPM-H3 ! Convert wedge-integrated energy density into angular energy densities for three successive - ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + ! wedges around the source wedge for this flux [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1]. Ep = En2d(a+2)*I_Angle_size Ec = En2d(a+1)*I_Angle_size Em = En2d(a) *I_Angle_size @@ -1274,10 +2031,10 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge endif curv_3 = (aR + aL) - 2.0*Ec ! Curvature - ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + ! Calculate angular flux rate [H Z2 T-3 ~> m3 s-3 or W m-2] ! Note that CFL_ang is negative here, so it looks odd compared with equivalent expressions. flux = u_ang*( aL - CFL_ang(A) * ( 0.5*(aR - aL) + curv_3 * (-CFL_ang(A) - 1.5) ) ) - ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] + ! Calculate amount of energy fluxed between wedges [H Z2 T-2 ~> m3 s-2 or J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux endif @@ -1285,23 +2042,24 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) end subroutine PPM_angular_advect !> Propagates internal waves at a single frequency. -subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) +subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution, - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. real, intent(in) :: dt !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: residual_loss !< internal tide energy loss due - !! to the residual at slopes [R Z3 T-3 ~> W m-2]. + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. ! Local variables real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: & speed ! The magnitude of the group velocity at the q points for corner adv [L T-1 ~> m s-1]. @@ -1326,7 +2084,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) type(loop_bounds_type) :: LB integer :: is, ie, js, je, asd, aed, na integer :: ish, ieh, jsh, jeh - integer :: i, j, a + integer :: i, j, a, fr, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; na = size(En,3) asd = 1-stencil ; aed = NAngle+stencil @@ -1348,6 +2106,13 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) Angle_size = (8.0*atan(1.0)) / real(NAngle) I_Angle_size = 1.0 / Angle_size + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: top of routine') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: top of routine', CS%En_sum + enddo ; enddo + endif + if (CS%corner_adv) then ! IMPLEMENT CORNER ADVECTION IN HORIZONTAL-------------------- ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS @@ -1359,6 +2124,9 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) speed(I,J) = 0.25*((cn(i,j) + cn(i+1,j+1)) + (cn(i+1,j) + cn(i,j+1))) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo + + call pass_var(speed, G%Domain) + do a=1,na ! Apply the propagation WITH CORNER ADVECTION/FINITE VOLUME APPROACH. LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie @@ -1384,35 +2152,76 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) Cgy_av(a)**2) enddo + speed_x(:,:) = 0. do j=jsh,jeh ; do I=ish-1,ieh f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I,J-1)) speed_x(I,j) = 0.5*(cn(i,j) + cn(i+1,j)) * G%mask2dCu(I,j) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo + + speed_y(:,:) = 0. do J=jsh-1,jeh ; do i=ish,ieh f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J)) speed_y(i,J) = 0.5*(cn(i,j) + cn(i,j+1)) * G%mask2dCv(i,J) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo + call pass_vector(speed_x, speed_y, G%Domain, stagger=CGRID_NE) + call pass_var(En, G%domain) + ! Apply propagation in x-direction (reflection included) LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss) - ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, US, CS, En, 'post-propagate_x') + ! fix underflows + do a=1,na ; do j=jsh,jeh ; do i=ish,ieh + if (abs(En(i,j,a)) < CS%En_underflow) En(i,j,a) = 0.0 + enddo ; enddo ; enddo + + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_x') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after propagate_x', CS%En_sum + enddo ; enddo + endif ! Update halos call pass_var(En, G%domain) call pass_var(residual_loss, G%domain) + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after halo update') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after halo update', CS%En_sum + enddo ; enddo + endif ! Apply propagation in y-direction (reflection included) ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss) - ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, US, CS, En, 'post-propagate_y') + ! fix underflows + do a=1,na ; do j=jsh,jeh ; do i=ish,ieh + if (abs(En(i,j,a)) < CS%En_underflow) En(i,j,a) = 0.0 + enddo ; enddo ; enddo + + call pass_var(En, G%domain) + call pass_var(residual_loss, G%domain) + + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_y') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after propagate_y', CS%En_sum + enddo ; enddo + endif + + endif + + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: bottom of routine') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: bottom of routine', CS%En_sum + enddo ; enddo endif end subroutine propagate @@ -1424,7 +2233,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2]. + !! band [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed), & intent(in) :: speed !< The magnitude of the group velocity at the cell !! corner points [L T-1 ~> m s-1]. @@ -1462,7 +2271,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x, y ! coordinates of cell corners [L ~> m] real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx, Idy ! inverse of dx,dy at cell corners [L-1 ~> m-1] real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx, dy ! dx,dy at cell corners [L ~> m] - real, dimension(2) :: E_new ! Energy in cell after advection for subray [R Z3 T-2 ~> J m-2]; set size + real, dimension(2) :: E_new ! Energy in cell after advection for subray [H Z2 T-2 ~> m3 s-2 or J m-2]; set size ! here to define Nsubrays - this should be made an input option later! ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1715,7 +2524,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2]. + !! band [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & intent(in) :: speed_x !< The magnitude of the group velocity at the !! Cu points [L T-1 ~> m s-1]. @@ -1728,17 +2537,17 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: residual_loss !< internal tide energy loss due - !! to the residual at slopes [R Z3 T-3 ~> W m-2]. + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - EnL, EnR ! Left and right face energy densities [R Z3 T-2 ~> J m-2]. + EnL, EnR ! Left and right face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZIB_(G),SZJ_(G)) :: & - flux_x ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux_x ! The internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(SZIB_(G)) :: & cg_p, & ! The x-direction group velocity [L T-1 ~> m s-1] - flux1 ! A 1-d copy of the x-direction internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux1 ! A 1-d copy of the x-direction internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & - Fdt_m, Fdt_p! Left and right energy fluxes [R Z3 L2 T-2 ~> J] + Fdt_m, Fdt_p! Left and right energy fluxes [H Z2 L2 T-2 ~> m5 s-2 or J] integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1763,12 +2572,15 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res enddo do j=jsh,jeh ; do i=ish,ieh - Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx [R Z3 L2 T-2 ~> J] - Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [R Z3 L2 T-2 ~> J] - - residual_loss(i,j,a) = residual_loss(i,j,a) + & - ((abs(flux_x(I-1,j)) * CS%residual(i,j) * G%IareaT(i,j)) + & - (abs(flux_x(I,j)) * CS%residual(i,j) * G%IareaT(i,j))) + Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + + ! only compute residual loss on partial reflection cells, remove numerical noise elsewhere + if (CS%refl_pref_logical(i,j)) then + residual_loss(i,j,a) = residual_loss(i,j,a) + & + ((abs(flux_x(I-1,j)) * CS%residual(i,j) * G%IareaT(i,j)) + & + (abs(flux_x(I,j)) * CS%residual(i,j) * G%IareaT(i,j))) + endif enddo ; enddo enddo ! a-loop @@ -1780,11 +2592,9 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res call reflect(Fdt_p, Nangle, CS, G, LB) !call teleport(Fdt_p, Nangle, CS, G, LB) - ! Update reflected energy [R Z3 T-2 ~> J m-2] + ! Update reflected energy [H Z2 T-2 ~> m3 s-2 or J m-2] do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh - ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging - ! call MOM_error(FATAL, "propagate_x: OutFlux>Available") - En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) + En(i,j,a) = En(i,j,a) + (G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) enddo ; enddo ; enddo end subroutine propagate_x @@ -1796,7 +2606,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2]. + !! band [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%JsdB:G%JedB), & intent(in) :: speed_y !< The magnitude of the group velocity at the !! Cv points [L T-1 ~> m s-1]. @@ -1809,17 +2619,17 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: residual_loss !< internal tide energy loss due - !! to the residual at slopes [R Z3 T-3 ~> W m-2]. + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. + EnL, EnR ! South and north face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & - flux_y ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux_y ! The internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(SZI_(G)) :: & cg_p, & ! The y-direction group velocity [L T-1 ~> m s-1] - flux1 ! A 1-d copy of the y-direction internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux1 ! A 1-d copy of the y-direction internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & - Fdt_m, Fdt_p! South and north energy fluxes [R Z3 L2 T-2 ~> J] + Fdt_m, Fdt_p! South and north energy fluxes [H Z2 L2 T-2 ~> m5 s-2 or J] integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1844,19 +2654,15 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res enddo do j=jsh,jeh ; do i=ish,ieh - Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx [R Z3 L2 T-2 ~> J] - Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [R Z3 L2 T-2 ~> J] - - residual_loss(i,j,a) = residual_loss(i,j,a) + & - ((abs(flux_y(i,J-1)) * CS%residual(i,j) * G%IareaT(i,j)) + & - (abs(flux_y(i,J)) * CS%residual(i,j) * G%IareaT(i,j))) - - !if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) then ! for debugging - ! call MOM_error(WARNING, "propagate_y: OutFlux>Available prior to reflection", .true.) - ! write(mesg,*) "flux_y_south=",flux_y(i,J-1),"flux_y_north=",flux_y(i,J),"En=",En(i,j,a), & - ! "cn_south=", speed_y(i,J-1) * (Cgy_av(a)), "cn_north=", speed_y(i,J) * (Cgy_av(a)) - ! call MOM_error(WARNING, mesg, .true.) - !endif + Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + + ! only compute residual loss on partial reflection cells, remove numerical noise elsewhere + if (CS%refl_pref_logical(i,j)) then + residual_loss(i,j,a) = residual_loss(i,j,a) + & + ((abs(flux_y(i,J-1)) * CS%residual(i,j) * G%IareaT(i,j)) + & + (abs(flux_y(i,J)) * CS%residual(i,j) * G%IareaT(i,j))) + endif enddo ; enddo enddo ! a-loop @@ -1868,10 +2674,8 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res call reflect(Fdt_p, Nangle, CS, G, LB) !call teleport(Fdt_p, Nangle, CS, G, LB) - ! Update reflected energy [R Z3 T-2 ~> J m-2] + ! Update reflected energy [H Z2 T-2 ~> m3 s-2 or J m-2] do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh - ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging - ! call MOM_error(FATAL, "propagate_y: OutFlux>Available", .true.) En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) enddo ; enddo ; enddo @@ -1882,12 +2686,12 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZIB_(G)), intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: h !< Energy density used to calculate the fluxes - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: hL !< Left- Energy densities in the reconstruction - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: hR !< Right- Energy densities in the reconstruction - !! [R Z3 T-2 ~> J m-2]. - real, dimension(SZIB_(G)), intent(inout) :: uh !< The zonal energy transport [R Z3 L2 T-3 ~> J s-1]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZIB_(G)), intent(out) :: uh !< The zonal energy transport [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< The j-index to work on. @@ -1897,7 +2701,7 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) !! the cell areas when estimating the CFL number. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. - real :: curv_3 ! A measure of the energy density curvature over a grid length [R Z3 T-2 ~> J m-2] + real :: curv_3 ! A measure of the energy density curvature over a grid length [H Z2 T-2 ~> m3 s-2 or J m-2] integer :: i do I=ish-1,ieh @@ -1925,12 +2729,13 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G)), intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Energy density used to calculate the - !! fluxes [R Z3 T-2 ~> J m-2]. + !! fluxes [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hL !< Left- Energy densities in the - !! reconstruction [R Z3 T-2 ~> J m-2]. + !! reconstruction [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hR !< Right- Energy densities in the - !! reconstruction [R Z3 T-2 ~> J m-2]. - real, dimension(SZI_(G)), intent(inout) :: vh !< The meridional energy transport [R Z3 L2 T-3 ~> J s-1]. + !! reconstruction [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G)), intent(out) :: vh !< The meridional energy transport + !! [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: J !< The j-index to work on. @@ -1941,7 +2746,7 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) !! the CFL number. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. - real :: curv_3 ! A measure of the energy density curvature over a grid length [R Z3 T-2 ~> J m-2] + real :: curv_3 ! A measure of the energy density curvature over a grid length [H Z2 T-2 ~> m3 s-2 or J m-2] integer :: i do i=ish,ieh @@ -1971,7 +2776,7 @@ subroutine reflect(En, NAngle, CS, G, LB) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. @@ -1983,7 +2788,7 @@ subroutine reflect(En, NAngle, CS, G, LB) ! values should collocate with angle_c [nondim] logical, dimension(G%isd:G%ied,G%jsd:G%jed) :: ridge ! tags of cells with double reflection - real, dimension(1:Nangle) :: En_reflected ! Energy reflected [R Z3 T-2 ~> J m-2]. + real, dimension(1:Nangle) :: En_reflected ! Energy reflected [H Z2 T-2 ~> m3 s-2 or J m-2]. real :: TwoPi ! 2*pi = 6.2831853... [nondim] real :: Angle_size ! size of beam wedge [rad] @@ -2078,7 +2883,7 @@ subroutine teleport(En, NAngle, CS, G, LB) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables @@ -2096,7 +2901,7 @@ subroutine teleport(En, NAngle, CS, G, LB) real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator [rad] real, dimension(1:NAngle) :: cos_angle ! Cosine of the beam angle relative to eastward [nondim] real, dimension(1:NAngle) :: sin_angle ! Sine of the beam angle relative to eastward [nondim] - real :: En_tele ! energy to be "teleported" [R Z3 T-2 ~> J m-2] + real :: En_tele ! energy to be "teleported" [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=160) :: mesg ! The text of an error message integer :: i, j, a integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain @@ -2171,7 +2976,7 @@ subroutine correct_halo_rotation(En, test, G, NAngle, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(:,:,:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a !! function of space, angular orientation, frequency, - !! and vertical mode [R Z3 T-2 ~> J m-2]. + !! and vertical mode [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G),2), & intent(in) :: test !< An x-unit vector that has been passed through !! the halo updates, to enable the rotation of the @@ -2181,7 +2986,7 @@ subroutine correct_halo_rotation(En, test, G, NAngle, halo) integer, intent(in) :: halo !< The halo size over which to do the calculations ! Local variables real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density - ! in a frequency band and mode [R Z3 T-2 ~> J m-2]. + ! in a frequency band and mode [H Z2 T-2 ~> m3 s-2 or J m-2]. integer, dimension(G%isd:G%ied) :: a_shift integer :: i_first, i_last, a_new integer :: a, i, j, ish, ieh, jsh, jeh, m, fr @@ -2228,19 +3033,23 @@ end subroutine correct_halo_rotation !> Calculates left/right edge values for PPM reconstruction in x-direction. subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width + ! [H Z2 T-2 ~> m3 s-2 or J m-2] real, parameter :: oneSixth = 1./6. ! One sixth [nondim] - real :: h_ip1, h_im1 ! The energy densities at adjacent points [R Z3 T-2 ~> J m-2] + real :: h_ip1, h_im1 ! The energy densities at adjacent points [H Z2 T-2 ~> m3 s-2 or J m-2] real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points - ! relative to the center point [R Z3 T-2 ~> J m-2] + ! relative to the center point [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -2303,19 +3112,23 @@ end subroutine PPM_reconstruction_x !> Calculates left/right edge valus for PPM reconstruction in y-direction. subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width + ! [H Z2 T-2 ~> m3 s-2 or J m-2] real, parameter :: oneSixth = 1./6. ! One sixth [nondim] - real :: h_jp1, h_jm1 ! The energy densities at adjacent points [R Z3 T-2 ~> J m-2] + real :: h_jp1, h_jm1 ! The energy densities at adjacent points [H Z2 T-2 ~> m3 s-2 or J m-2] real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points - ! relative to the center point [R Z3 T-2 ~> J m-2] + ! relative to the center point [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -2379,18 +3192,22 @@ end subroutine PPM_reconstruction_y !! than h_min, with a minimum of h_min otherwise. subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] real, intent(in) :: h_min !< The minimum value that can be - !! obtained by a concave parabolic fit [R Z3 T-2 ~> J m-2] + !! obtained by a concave parabolic fit + !! [H Z2 T-2 ~> m3 s-2 or J m-2] integer, intent(in) :: iis !< Start i-index for computations integer, intent(in) :: iie !< End i-index for computations integer, intent(in) :: jis !< Start j-index for computations integer, intent(in) :: jie !< End j-index for computations ! Local variables - real :: curv ! The cell-area normalized curvature [R Z3 T-2 ~> J m-2] - real :: dh ! The difference between the edge values [R Z3 T-2 ~> J m-2] + real :: curv ! The cell-area normalized curvature [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: dh ! The difference between the edge values [H Z2 T-2 ~> m3 s-2 or J m-2] real :: scale ! A rescaling factor used to give a minimum cell value of at least h_min [nondim] integer :: i, j @@ -2415,8 +3232,9 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) enddo ; enddo end subroutine PPM_limit_pos -subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) +subroutine register_int_tide_restarts(G, GV, US, param_file, CS, restart_CS) 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(int_tide_CS), pointer :: CS !< Internal tide control structure @@ -2424,16 +3242,22 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) ! This subroutine is used to allocate and register any fields in this module ! that should be written to or read from the restart file. + logical :: non_Bous ! If true, this run is fully non-Boussinesq + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq logical :: use_int_tides integer :: num_freq, num_angle , num_mode, period_1 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, i, j, a, fr - character(64) :: var_name, cfr + character(64) :: var_name, cfr, units type(axis_info) :: axes_inttides(2) real, dimension(:), allocatable :: angles, freqs ! Lables for angles and frequencies [nondim] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-2 ~> m3 s-2 or J m-2] isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + HZ2_T2_to_J_m2 = GV%H_to_MKS*(US%Z_to_m**2)*(US%s_to_T**2) + if (associated(CS)) then call MOM_error(WARNING, "register_int_tide_restarts called "//& "with an associated control structure.") @@ -2447,6 +3271,19 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) call get_param(param_file, "MOM", "INTERNAL_TIDE_FREQS", num_freq, default=1) call get_param(param_file, "MOM", "INTERNAL_TIDE_MODES", num_mode, default=1) + ! define restart units depemding on Boussinesq + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + non_Bous = .not.(Boussinesq .or. semi_Boussinesq) + + units="J m-2" + if (non_Bous) units="m3 s-2" + allocate (angles(num_angle)) allocate (freqs(num_freq)) @@ -2473,7 +3310,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) ! register all 4d restarts and copy into full Energy array when restarting from previous state call register_restart_field(CS%En_restart_mode1(:,:,:,:), "IW_energy_mode1", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 1", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2483,7 +3320,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 2) then call register_restart_field(CS%En_restart_mode2(:,:,:,:), "IW_energy_mode2", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 2", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2495,7 +3332,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 3) then call register_restart_field(CS%En_restart_mode3(:,:,:,:), "IW_energy_mode3", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 3", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2507,7 +3344,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 4) then call register_restart_field(CS%En_restart_mode4(:,:,:,:), "IW_energy_mode4", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 4", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2519,7 +3356,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 5) then call register_restart_field(CS%En_restart_mode5(:,:,:,:), "IW_energy_mode5", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 5", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2533,7 +3370,7 @@ end subroutine register_int_tide_restarts !> This subroutine initializes the internal tides module. subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) type(time_type), target, intent(in) :: Time !< The current model time. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time @@ -2550,6 +3387,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) real, dimension(:,:), allocatable :: ridge_temp ! array for temporary storage of flags ! of cells with double-reflecting ridges [nondim] logical :: use_int_tides, use_temperature + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure real :: IGW_c1_thresh ! A threshold first mode internal wave speed below which all higher ! mode speeds are not calculated but simply assigned a speed of 0 [L T-1 ~> m s-1]. real :: kappa_h2_factor ! A roughness scaling factor [nondim] @@ -2557,6 +3395,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! nominal ocean depth, or a negative value for no limit [nondim] real :: period_1 ! The period of the gravest modeled mode [T ~> s] real :: period ! A tidal period read from namelist [T ~> s] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal [m3 s-2 or J m-2 ~> H Z2 T-2] integer :: num_angle, num_freq, num_mode, m, fr integer :: isd, ied, jsd, jed, a, id_ang, i, j, nz type(axes_grp) :: axes_ang @@ -2578,6 +3420,11 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed nz = GV%ke + HZ2_T2_to_J_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**2) + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + J_m2_to_HZ2_T2 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + CS%initialized = .true. use_int_tides = .false. @@ -2614,11 +3461,15 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%frequency(num_freq)) + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + ! The periods of the tidal constituents for internal tides raytracing call read_param(param_file, "TIDAL_PERIODS", periods) do fr=1,num_freq - period = extract_real(periods, " ,", fr, 0.) + period = US%s_to_T*extract_real(periods, " ,", fr, 0.) if (period == 0.) call MOM_error(FATAL, "MOM_internal_tides: invalid tidal period") CS%frequency(fr) = 8.0*atan(1.0)/period enddo @@ -2668,6 +3519,33 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag + call get_param(param_file, mdl, "INTERNAL_TIDES_UPDATE_KD", CS%update_Kd, & + "If true, internal tides ray tracing changes Kd for dynamics.", & + default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDES_REFRACTION", CS%apply_refraction, & + "If true, internal tides ray tracing does refraction.", & + default=.true.) + call get_param(param_file, mdl, "INTERNAL_TIDES_PROPAGATION", CS%apply_propagation, & + "If true, internal tides ray tracing does propagate.", & + default=.true.) + call get_param(param_file, mdl, "INTERNAL_TIDES_ONLY_INIT_FORCING", CS%init_forcing_only, & + "If true, internal tides ray tracing only applies forcing at first step (debugging).", & + default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDES_FORCE_POS_EN", CS%force_posit_En, & + "If true, force energy to be positive by removing subroundoff negative values.", & + default=.true.) + call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & + "The minimum diapycnal diffusivity.", & + units="m2 s-1", default=2e-6, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "MINTHICK_TKE_TO_KD", CS%min_thick_layer_Kd, & + "The minimum thickness allowed with TKE_to_Kd.", & + units="m", default=1e-6, scale=GV%m_to_H) + call get_param(param_file, mdl, "ITIDES_MIXING_EFFIC", CS%mixing_effic, & + "Mixing efficiency for internal tides raytracing", & + units="nondim", default=0.2) + call get_param(param_file, mdl, "MAX_TKE_TO_KD", CS%max_TKE_to_Kd, & + "Limiter for TKE_to_Kd.", & + units="", default=1e9, scale=US%Z_to_m*US%s_to_T**2) call get_param(param_file, mdl, "INTERNAL_TIDE_DECAY_RATE", CS%decay_rate, & "The rate at which internal tide energy is lost to the "//& "interior ocean internal wave field.", & @@ -2702,7 +3580,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "If true, apply scattering due to small-scale roughness as a sink.", & default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_RESIDUAL_DRAG", CS%apply_residual_drag, & - "If true, TBD", & + "If true, apply drag due to critical slopes", & default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_DRAG_MIN_DEPTH", CS%drag_min_depth, & "The minimum total ocean thickness that will be used in the denominator "//& @@ -2713,10 +3591,16 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "If true, apply wave breaking as a sink.", & default=.false.) call get_param(param_file, mdl, "EN_CHECK_TOLERANCE", CS%En_check_tol, & - "An energy density tolerance for flagging points with an imbalance in the "//& - "internal tide energy budget when INTERNAL_TIDE_FROUDE_DRAG is True.", & - units="J m-2", default=1.0e-10, scale=US%W_m2_to_RZ3_T3*US%s_to_T, & + "An energy density tolerance for flagging points with small negative "//& + "internal tide energy.", & + units="J m-2", default=1.0, scale=J_m2_to_HZ2_T2, & do_not_log=.not.CS%apply_Froude_drag) + call get_param(param_file, mdl, "EN_UNDERFLOW", CS%En_underflow, & + "A small energy density below which Energy is set to zero.", & + units="J m-2", default=1.0e-100, scale=J_m2_to_HZ2_T2) + call get_param(param_file, mdl, "EN_RESTART_POWER", CS%En_restart_power, & + "A power factor to save larger values x 2**(power) in restart files.", & + units="nondim", default=0) call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", & @@ -2726,7 +3610,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "mode speeds are not calculated but are simply reported as 0. This must be "//& "non-negative for the wave_speeds routine to be used.", & units="m s-1", default=0.01, scale=US%m_s_to_L_T) - + call get_param(param_file, mdl, "INTWAVE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "UNIFORM_TEST_CG", CS%uniform_test_cg, & "If positive, a uniform group velocity of internal tide for test case", & default=-1., units="m s-1", scale=US%m_s_to_L_T) @@ -2748,6 +3635,17 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) + call get_param(param_file, mdl, "GAMMA_OSBORN", CS%gamma_osborn, & + "The mixing efficiency for internan tides from Osborn 1980 ", & + units="nondim", default=0.2) + call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE", CS%Int_tide_decay_scale, & + "The decay scale away from the bottom for tidal TKE with "//& + "the new coding when INT_TIDE_DISSIPATION is used.", & + units="m", default=500.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE_SLOPES", CS%Int_tide_decay_scale_slope, & + "The slope decay scale away from the bottom for tidal TKE with "//& + "the new coding when INT_TIDE_DISSIPATION is used.", & + units="m", default=100.0, scale=GV%m_to_H) ! Allocate various arrays needed for loss rates allocate(h2(isd:ied,jsd:jed), source=0.0) @@ -2757,6 +3655,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%TKE_itidal_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%TKE_Froude_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%TKE_residual_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%TKE_slope_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%tot_leak_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_quad_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_itidal_loss(isd:ied,jsd:jed), source=0.0) @@ -2769,6 +3668,15 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%int_N2w2(isd:ied,jsd:jed,num_mode), source=0.0) allocate(CS%w_struct(isd:ied,jsd:jed,1:nz+1,num_mode), source=0.0) allocate(CS%u_struct(isd:ied,jsd:jed,1:nz,num_mode), source=0.0) + allocate(CS%error_mode(num_freq,num_mode), source=0.0) + allocate(CS%En_ini_glo(num_freq,num_mode), source=0.0) + allocate(CS%En_end_glo(num_freq,num_mode), source=0.0) + allocate(CS%TKE_leak_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_quad_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_Froude_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_itidal_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_residual_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_input_glo_dt(num_freq,num_mode), source=0.0) ! Compute the fixed part of the bottom drag loss from baroclinic modes call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -2794,7 +3702,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) endif ! Compute the fixed part; units are [R Z4 H-1 L-2 ~> kg m-2 or m] here ! will be multiplied by N and the squared near-bottom velocity (and by the - ! near-bottom density in non-Boussinesq mode) to get into [R Z3 T-3 ~> W m-2] + ! near-bottom density in non-Boussinesq mode) to get into [H Z2 T-3 ~> m3 s-3 or W m-2] CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor* GV%H_to_RZ * US%L_to_Z*kappa_itides * h2(i,j) enddo ; enddo @@ -2883,12 +3791,23 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! residual allocate(CS%residual(isd:ied,jsd:jed), source=0.0) - do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (CS%refl_pref_logical(i,j)) then - CS%residual(i,j) = 1. - CS%refl_pref(i,j) - CS%trans(i,j) - endif - enddo ; enddo - call pass_var(CS%residual, G%domain) + if (CS%apply_residual_drag) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%residual(i,j) = 1. - (CS%refl_pref(i,j) - CS%trans(i,j)) + endif + enddo ; enddo + call pass_var(CS%residual, G%domain) + else + ! report residual of transmission/reflection onto reflection + ! this ensure energy budget is conserved + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%refl_pref(i,j) = 1. - CS%trans(i,j) + endif + enddo ; enddo + call pass_var(CS%refl_pref, G%domain) + endif CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) @@ -2928,7 +3847,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Register 2-D energy density (summed over angles, freq, modes) CS%id_tot_En = register_diag_field('ocean_model', 'ITide_tot_En', diag%axesT1, & Time, 'Internal tide total energy density', & - 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + 'J m-2', conversion=HZ2_T2_to_J_m2) allocate(CS%id_itide_drag(CS%nFreq, CS%nMode), source=-1) allocate(CS%id_TKE_itidal_input(CS%nFreq), source=-1) @@ -2939,27 +3858,27 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_TKE_itidal_input(fr) = register_diag_field('ocean_model', var_name, diag%axesT1, & Time, 'Conversion from barotropic to baroclinic tide, '//& - var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) enddo ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & Time, 'Internal tide energy loss to background drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_quad_loss = register_diag_field('ocean_model', 'ITide_tot_quad_loss', diag%axesT1, & Time, 'Internal tide energy loss to bottom drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_itidal_loss = register_diag_field('ocean_model', 'ITide_tot_itidal_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_Froude_loss = register_diag_field('ocean_model', 'ITide_tot_Froude_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave breaking', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_residual_loss = register_diag_field('ocean_model', 'ITide_tot_residual_loss', diag%axesT1, & Time, 'Internal tide energy loss to residual on slopes', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_allprocesses_loss = register_diag_field('ocean_model', 'ITide_tot_allprocesses_loss', diag%axesT1, & Time, 'Internal tide energy loss summed over all processes', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) allocate(CS%id_En_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_En_ang_mode(CS%nFreq,CS%nMode), source=-1) @@ -2991,14 +3910,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_En_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + diag%axesT1, Time, var_descript, 'J m-2', conversion=HZ2_T2_to_J_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 3-D (i,j,a) energy density for each frequency and mode write(var_name, '("Itide_En_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide angular energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'J m-2 band-1', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + axes_ang, Time, var_descript, 'J m-2 band-1', conversion=HZ2_T2_to_J_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 2-D energy loss (summed over angles) for each frequency and mode @@ -3006,37 +3925,37 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_wavedrag_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Leakage loss write(var_name, '("Itide_leak_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to leakage from frequency ",i1," mode ",i1)') fr, m CS%id_leak_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Quad loss write(var_name, '("Itide_quad_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy quad loss from frequency ",i1," mode ",i1)') fr, m CS%id_quad_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Froude loss write(var_name, '("Itide_froude_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy Froude loss from frequency ",i1," mode ",i1)') fr, m CS%id_froude_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! residual losses write(var_name, '("Itide_residual_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy residual loss from frequency ",i1," mode ",i1)') fr, m CS%id_residual_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! all loss processes write(var_name, '("Itide_allprocesses_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to all processes from frequency ",i1," mode ",i1)') fr, m CS%id_allprocesses_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 3-D (i,j,a) energy loss for each frequency and mode @@ -3044,7 +3963,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_wavedrag_loss_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'W m-2 band-1', conversion=US%RZ3_T3_to_W_m2) + axes_ang, Time, var_descript, 'W m-2 band-1', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 2-D period-averaged near-bottom horizontal velocity for each frequency and mode @@ -3107,7 +4026,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) enddo ! Initialize the module that calculates the wave speeds. - call wave_speed_init(CS%wave_speed, c1_thresh=IGW_c1_thresh) + call wave_speed_init(CS%wave_speed, GV, c1_thresh=IGW_c1_thresh, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells) end subroutine internal_tides_init diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index d124450536..8f388dc263 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -18,6 +18,8 @@ module MOM_lateral_mixing_coeffs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init use MOM_open_boundary, only : ocean_OBC_type +use MOM_MEKE_types, only : MEKE_type + implicit none ; private @@ -50,6 +52,14 @@ module MOM_lateral_mixing_coeffs !! as the vertical structure of thickness diffusivity. logical :: kdgl90_use_ebt_struct !< If true, uses the equivalent barotropic structure !! as the vertical structure of diffusivity in the GL90 scheme. + logical :: kdgl90_use_sqg_struct !< If true, uses the surface quasigeostrophic structure + !! as the vertical structure of diffusivity in the GL90 scheme. + logical :: khth_use_sqg_struct !< If true, uses the surface quasigeostrophic structure + !! as the vertical structure of thickness diffusivity. + logical :: khtr_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of tracer diffusivity. + logical :: khtr_use_sqg_struct !< If true, uses the surface quasigeostrophic structure + !! as the vertical structure of tracer diffusivity. logical :: calculate_cg1 !< If true, calls wave_speed() to calculate the first !! baroclinic wave speed and populate CS%cg1. !! This parameter is set depending on other parameters. @@ -112,7 +122,16 @@ module MOM_lateral_mixing_coeffs real, allocatable :: slope_x(:,:,:) !< Zonal isopycnal slope [Z L-1 ~> nondim] real, allocatable :: slope_y(:,:,:) !< Meridional isopycnal slope [Z L-1 ~> nondim] - real, allocatable :: ebt_struct(:,:,:) !< Vertical structure function to scale diffusivities with [nondim] + real, allocatable :: ebt_struct(:,:,:) !< EBT vertical structure to scale diffusivities with [nondim] + real, allocatable :: sqg_struct(:,:,:) !< SQG vertical structure to scale diffusivities with [nondim] + real, allocatable :: BS_struct(:,:,:) !< Vertical structure function used in backscatter [nondim] + real, allocatable :: khth_struct(:,:,:) !< Vertical structure function used in thickness diffusivity [nondim] + real, allocatable :: khtr_struct(:,:,:) !< Vertical structure function used in tracer diffusivity [nondim] + real, allocatable :: kdgl90_struct(:,:,:) !< Vertical structure function used in GL90 diffusivity [nondim] + real :: BS_EBT_power !< Power to raise EBT vertical structure to. Default 0.0. + real :: sqg_expo !< Exponent for SQG vertical structure [nondim]. Default 1.0 + logical :: BS_use_sqg_struct !< If true, use sqg_stuct for backscatter vertical structure. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & Laplac3_const_u !< Laplacian metric-dependent constants [L3 ~> m3] @@ -160,6 +179,8 @@ module MOM_lateral_mixing_coeffs integer :: id_N2_u=-1, id_N2_v=-1, id_S2_u=-1, id_S2_v=-1 integer :: id_dzu=-1, id_dzv=-1, id_dzSxN=-1, id_dzSyN=-1 integer :: id_Rd_dx=-1, id_KH_u_QG = -1, id_KH_v_QG = -1 + integer :: id_sqg_struct=-1, id_BS_struct=-1, id_khth_struct=-1, id_khtr_struct=-1 + integer :: id_kdgl90_struct=-1 type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. !>@} @@ -170,7 +191,7 @@ module MOM_lateral_mixing_coeffs end type VarMix_CS public VarMix_init, VarMix_end, calc_slope_functions, calc_resoln_function -public calc_QG_slopes, calc_QG_Leith_viscosity, calc_depth_function +public calc_QG_slopes, calc_QG_Leith_viscosity, calc_depth_function, calc_sqg_struct contains @@ -211,13 +232,15 @@ subroutine calc_depth_function(G, CS) end subroutine calc_depth_function !> Calculates and stores the non-dimensional resolution functions -subroutine calc_resoln_function(h, tv, G, GV, US, CS) +subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + type(MEKE_type), intent(in) :: MEKE !< MEKE struct + real, intent(in) :: dt !< Time increment [T ~> s] ! Local variables ! Depending on the power-function being used, dimensional rescaling may be limited, so some @@ -228,7 +251,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) real :: dx_term ! A term in the denominator [L2 T-2 ~> m2 s-2] or [m2 s-2] integer :: power_2 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: i, j + integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -238,7 +261,8 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) if (CS%calculate_cg1) then if (.not. allocated(CS%cg1)) call MOM_error(FATAL, & "calc_resoln_function: %cg1 is not associated with Resoln_scaled_Kh.") - if (CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) then + if (CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & + .or. CS%khtr_use_ebt_struct .or. CS%BS_EBT_power>0.) then if (.not. allocated(CS%ebt_struct)) call MOM_error(FATAL, & "calc_resoln_function: %ebt_struct is not associated with RESOLN_USE_EBT.") if (CS%Resoln_use_ebt) then @@ -258,6 +282,51 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) call create_group_pass(CS%pass_cg1, CS%cg1, G%Domain) call do_group_pass(CS%pass_cg1, G%Domain) endif + if (CS%BS_use_sqg_struct .or. CS%khth_use_sqg_struct .or. CS%khtr_use_sqg_struct & + .or. CS%kdgl90_use_sqg_struct .or. CS%id_sqg_struct>0) then + call calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE) + call pass_var(CS%sqg_struct, G%Domain) + endif + + if (CS%BS_EBT_power>0.) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%BS_struct(i,j,k) = CS%ebt_struct(i,j,k)**CS%BS_EBT_power + enddo ; enddo ; enddo + elseif (CS%BS_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%BS_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif + + if (CS%khth_use_ebt_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khth_struct(i,j,k) = CS%ebt_struct(i,j,k) + enddo ; enddo ; enddo + elseif (CS%khth_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khth_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif + + if (CS%khtr_use_ebt_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khtr_struct(i,j,k) = CS%ebt_struct(i,j,k) + enddo ; enddo ; enddo + elseif (CS%khtr_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khtr_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif + + if (CS%kdgl90_use_ebt_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%kdgl90_struct(i,j,k) = CS%ebt_struct(i,j,k) + enddo ; enddo ; enddo + elseif (CS%kdgl90_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%kdgl90_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif ! Calculate and store the ratio between deformation radius and grid-spacing ! at h-points [nondim]. @@ -452,16 +521,94 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) if (query_averaging_enabled(CS%diag)) then if (CS%id_Res_fn > 0) call post_data(CS%id_Res_fn, CS%Res_fn_h, CS%diag) + if (CS%id_BS_struct > 0) call post_data(CS%id_BS_struct, CS%BS_struct, CS%diag) + if (CS%id_khth_struct > 0) call post_data(CS%id_khth_struct, CS%khth_struct, CS%diag) + if (CS%id_khtr_struct > 0) call post_data(CS%id_khtr_struct, CS%khtr_struct, CS%diag) + if (CS%id_kdgl90_struct > 0) call post_data(CS%id_kdgl90_struct, CS%kdgl90_struct, CS%diag) endif if (CS%debug) then - call hchksum(CS%cg1, "calc_resoln_fn cg1", G%HI, haloshift=1, scale=US%L_T_to_m_s) + call hchksum(CS%cg1, "calc_resoln_fn cg1", G%HI, haloshift=1, unscale=US%L_T_to_m_s) call uvchksum("Res_fn_[uv]", CS%Res_fn_u, CS%Res_fn_v, G%HI, haloshift=0, & - scale=1.0, scalar_pair=.true.) + unscale=1.0, scalar_pair=.true.) endif end subroutine calc_resoln_function +!> Calculates and stores functions of SQG mode +subroutine calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv ! s] + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct + type(MEKE_type), intent(in) :: MEKE !< MEKE struct + + ! Local variables + real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & + e ! The interface heights relative to mean sea level [Z ~> m]. + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G), SZJ_(G)) :: f ! Absolute value of the Coriolis parameter at h point [T-1 ~> s-1] + real :: N2 ! Positive buoyancy frequency square or zero [L2 Z-2 T-2 ~> s-2] + real :: dzc ! Spacing between two adjacent layers in stretched vertical coordinate [m] + real :: f_subround ! The minimal resolved value of Coriolis parameter to prevent division by zero [T-1 ~> s-1] + real, dimension(SZI_(G), SZJ_(G)) :: Le ! Eddy length scale [m] + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + f_subround = 1.0e-40 * US%s_to_T + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions: "//& + "Module must be initialized before it is used.") + + call find_eta(h, tv, G, GV, US, e, halo_size=2) + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v,dzu=dzu, dzv=dzv, & + dzSxN=dzSxN, dzSyN=dzSyN, halo=1) + + if (CS%sqg_expo<=0.) then + CS%sqg_struct(:,:,:) = 1. + else + do j=js,je ; do i=is,ie + CS%sqg_struct(i,j,1) = 1.0 + enddo ; enddo + if (allocated(MEKE%Le)) then + do j=js,je ; do i=is,ie + Le(i,j) = MEKE%Le(i,j) + f(i,j) = max(0.25 * abs((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))), f_subround) + enddo ; enddo + else + do j=js,je ; do i=is,ie + Le(i,j) = sqrt(G%areaT(i,j)) + f(i,j) = max(0.25 * abs((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))), f_subround) + enddo ; enddo + endif + do k=2,nz ; do j=js,je ; do i=is,ie + N2 = max(0.25 * ((N2_u(I-1,j,k) + N2_u(I,j,k)) + (N2_v(i,J-1,k) + N2_v(i,J,k))), 0.0) + dzc = 0.25 * ((dzu(I-1,j,k) + dzu(I,j,k)) + (dzv(i,J-1,k) + dzv(i,J,k))) + CS%sqg_struct(i,j,k) = CS%sqg_struct(i,j,k-1) * & + exp(-CS%sqg_expo * (dzc * sqrt(N2)/(f(i,j) * Le(i,j)))) + enddo ; enddo ; enddo + endif + + + if (query_averaging_enabled(CS%diag)) then + if (CS%id_sqg_struct > 0) call post_data(CS%id_sqg_struct, CS%sqg_struct, CS%diag) + if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) + if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) + endif + +end subroutine calc_sqg_struct + !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. !! style scaling of diffusivity subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) @@ -497,8 +644,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, halo=1, OBC=OBC) call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) else - !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true.) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e) endif endif @@ -657,11 +803,11 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C if (CS%debug) then call uvchksum("calc_Visbeck_coeffs_old slope_[xy]", slope_x, slope_y, G%HI, & - scale=US%Z_to_L, haloshift=1) + unscale=US%Z_to_L, haloshift=1) call uvchksum("calc_Visbeck_coeffs_old N2_u, N2_v", N2_u, N2_v, G%HI, & - scale=US%L_to_Z**2*US%s_to_T**2, scalar_pair=.true.) + unscale=US%L_to_Z**2*US%s_to_T**2, scalar_pair=.true.) call uvchksum("calc_Visbeck_coeffs_old SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & - scale=US%s_to_T, scalar_pair=.true.) + unscale=US%s_to_T, scalar_pair=.true.) endif end subroutine calc_Visbeck_coeffs_old @@ -701,9 +847,9 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, crop = CS%cropping_distance>=0. ! Only filter out in-/out-cropped interface is parameter if non-negative if (CS%debug) then - call uvchksum("calc_Eady_growth_rate_2D dz[uv]", dzu, dzv, G%HI, scale=US%Z_to_m, scalar_pair=.true.) + call uvchksum("calc_Eady_growth_rate_2D dz[uv]", dzu, dzv, G%HI, unscale=US%Z_to_m, scalar_pair=.true.) call uvchksum("calc_Eady_growth_rate_2D dzS2N2[uv]", dzSxN, dzSyN, G%HI, & - scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + unscale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) endif !$OMP parallel do default(shared) @@ -814,14 +960,14 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, if (CS%debug) then call uvchksum("calc_Eady_growth_rate_2D SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & - scale=US%s_to_T, scalar_pair=.true.) + unscale=US%s_to_T, scalar_pair=.true.) endif end subroutine calc_Eady_growth_rate_2D !> The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. -subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes) +subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] @@ -829,8 +975,6 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface position [Z ~> m] ! type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - logical, intent(in) :: calculate_slopes !< If true, calculate slopes - !! internally otherwise use slopes stored in CS ! Local variables real :: E_x(SZIB_(G),SZJ_(G)) ! X-slope of interface at u points [Z L-1 ~> nondim] (for diagnostics) real :: E_y(SZI_(G),SZJB_(G)) ! Y-slope of interface at v points [Z L-1 ~> nondim] (for diagnostics) @@ -894,28 +1038,17 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop !$OMP parallel do default(shared) private(E_x,E_y,S2,Hdn,Hup,H_geom,N2) do k=nz,CS%VarMix_Ktop,-1 - if (calculate_slopes) then - ! Calculate the interface slopes E_x and E_y and u- and v- points respectively - do j=js-1,je+1 ; do I=is-1,ie - E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) - ! Mask slopes where interface intersects topography - if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. - enddo ; enddo - do J=js-1,je ; do i=is-1,ie+1 - E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) - ! Mask slopes where interface intersects topography - if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. - enddo ; enddo - else ! This branch is not used. - do j=js-1,je+1 ; do I=is-1,ie - E_x(I,j) = CS%slope_x(I,j,k) - if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. - enddo ; enddo - do J=js-1,je ; do i=is-1,ie+1 - E_y(i,J) = CS%slope_y(i,J,k) - if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. - enddo ; enddo - endif + ! Calculate the interface slopes E_x and E_y and u- and v- points respectively + do j=js-1,je+1 ; do I=is-1,ie + E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) + ! Mask slopes where interface intersects topography + if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. + enddo ; enddo + do J=js-1,je ; do i=is-1,ie+1 + E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) + ! Mask slopes where interface intersects topography + if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. + enddo ; enddo ! Calculate N*S*h from this layer and add to the sum do j=js,je ; do I=is-1,ie @@ -1204,6 +1337,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! mode wave speed as the starting point for iterations. real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_lateral_mixing_coeffs" ! This module's name. @@ -1262,14 +1396,40 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, uses the equivalent barotropic wave speed instead "//& "of first baroclinic wave for calculating the resolution fn.",& default=.false.) + call get_param(param_file, mdl, "BACKSCAT_EBT_POWER", CS%BS_EBT_power, & + "Power to raise EBT vertical structure to when backscatter "// & + "has vertical structure.", units="nondim", default=0.0) + call get_param(param_file, mdl, "BS_USE_SQG_STRUCT", CS%BS_use_sqg_struct, & + "If true, the SQG vertical structure is used for backscatter "//& + "on the condition that BS_EBT_power=0", & + default=.false.) + call get_param(param_file, mdl, "SQG_EXPO", CS%sqg_expo, & + "Nondimensional exponent coeffecient of the SQG mode "// & + "that is used for the vertical struture of diffusivities.", units="nondim", default=1.0) call get_param(param_file, mdl, "KHTH_USE_EBT_STRUCT", CS%khth_use_ebt_struct, & "If true, uses the equivalent barotropic structure "//& "as the vertical structure of thickness diffusivity.",& default=.false.) + call get_param(param_file, mdl, "KHTH_USE_SQG_STRUCT", CS%khth_use_sqg_struct, & + "If true, uses the surface quasigeostrophic structure "//& + "as the vertical structure of thickness diffusivity.",& + default=.false.) + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%khtr_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of tracer diffusivity.",& + default=.false.) + call get_param(param_file, mdl, "KHTR_USE_SQG_STRUCT", CS%khtr_use_sqg_struct, & + "If true, uses the surface quasigeostrophic structure "//& + "as the vertical structure of tracer diffusivity.",& + default=.false.) call get_param(param_file, mdl, "KD_GL90_USE_EBT_STRUCT", CS%kdgl90_use_ebt_struct, & "If true, uses the equivalent barotropic structure "//& "as the vertical structure of diffusivity in the GL90 scheme.",& default=.false.) + call get_param(param_file, mdl, "KD_GL90_USE_SQG_STRUCT", CS%kdgl90_use_sqg_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of diffusivity in the GL90 scheme.",& + default=.false.) call get_param(param_file, mdl, "KHTH_SLOPE_CFF", KhTh_Slope_Cff, & "The nondimensional coefficient in the Visbeck formula "//& "for the interface depth diffusivity", units="nondim", default=0.0) @@ -1287,7 +1447,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) default=1.0e-17, units="s-1", scale=US%T_to_s) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", use_FGNV_streamfn, & default=.false., do_not_log=.true.) - CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct + CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn .or. CS%khth_use_ebt_struct & + .or. CS%kdgl90_use_ebt_struct .or. CS%BS_EBT_power>0. CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. use_MEKE ! Indicate whether to calculate the Eady growth rate CS%calculate_Eady_growth_rate = use_MEKE .or. (KhTr_Slope_Cff>0.) .or. (KhTh_Slope_Cff>0.) @@ -1311,7 +1472,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ISO is true.") endif - if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) then + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & + .or. CS%BS_EBT_power>0. .or. CS%khtr_use_ebt_struct) then in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & "The depth below which N2 is monotonized to avoid stratification "//& @@ -1321,6 +1483,47 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif + + if (CS%BS_EBT_power>0. .and. CS%BS_use_sqg_struct) then + call MOM_error(FATAL, & + "calc_resoln_function: BS_EBT_POWER>0. & + & and BS_USE_SQG=True cannot be set together") + endif + + if (CS%khth_use_ebt_struct .and. CS%khth_use_sqg_struct) then + call MOM_error(FATAL, & + "calc_resoln_function: Only one of KHTH_USE_EBT_STRUCT & + & and KHTH_USE_SQG_STRUCT can be true") + endif + + if (CS%khtr_use_ebt_struct .and. CS%khtr_use_sqg_struct) then + call MOM_error(FATAL, & + "calc_resoln_function: Only one of KHTR_USE_EBT_STRUCT & + & and KHTR_USE_SQG_STRUCT can be true") + endif + + if (CS%kdgl90_use_ebt_struct .and. CS%kdgl90_use_sqg_struct) then + call MOM_error(FATAL, & + "calc_resoln_function: Only one of KD_GL90_USE_EBT_STRUCT & + & and KD_GL90_USE_SQG_STRUCT can be true") + endif + + if (CS%BS_EBT_power>0. .or. CS%BS_use_sqg_struct) then + allocate(CS%BS_struct(isd:ied,jsd:jed,GV%ke), source=0.0) + endif + + if (CS%khth_use_ebt_struct .or. CS%khth_use_sqg_struct) then + allocate(CS%khth_struct(isd:ied, jsd:jed, gv%ke), source=0.0) + endif + + if (CS%khtr_use_ebt_struct .or. CS%khtr_use_sqg_struct) then + allocate(CS%khtr_struct(isd:ied, jsd:jed, gv%ke), source=0.0) + endif + + if (CS%kdgl90_use_ebt_struct .or. CS%kdgl90_use_sqg_struct) then + allocate(CS%kdgl90_struct(isd:ied, jsd:jed, gv%ke), source=0.0) + endif + 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, & @@ -1333,7 +1536,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) endif endif - if (CS%use_stored_slopes) then + if (CS%use_stored_slopes .or. CS%sqg_expo>0.0) then ! CS%calculate_Eady_growth_rate=.true. in_use = .true. allocate(CS%slope_x(IsdB:IedB,jsd:jed,GV%ke+1), source=0.0) @@ -1416,7 +1619,31 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'm2', conversion=US%L_to_m**2) endif - if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then + CS%id_sqg_struct = register_diag_field('ocean_model', 'sqg_struct', diag%axesTl, Time, & + 'Vertical structure of SQG mode', 'nondim') + if (CS%BS_use_sqg_struct .or. CS%khth_use_sqg_struct .or. CS%khtr_use_sqg_struct & + .or. CS%kdgl90_use_sqg_struct .or. CS%id_sqg_struct>0) then + allocate(CS%sqg_struct(isd:ied,jsd:jed,GV%ke), source=0.0) + endif + + if (CS%BS_EBT_power>0. .or. CS%BS_use_sqg_struct) then + CS%id_BS_struct = register_diag_field('ocean_model', 'BS_struct', diag%axesTl, Time, & + 'Vertical structure of backscatter', 'nondim') + endif + if (CS%khth_use_ebt_struct .or. CS%khth_use_sqg_struct) then + CS%id_khth_struct = register_diag_field('ocean_model', 'khth_struct', diag%axesTl, Time, & + 'Vertical structure of thickness diffusivity', 'nondim') + endif + if (CS%khtr_use_ebt_struct .or. CS%khtr_use_sqg_struct) then + CS%id_khtr_struct = register_diag_field('ocean_model', 'khtr_struct', diag%axesTl, Time, & + 'Vertical structure of tracer diffusivity', 'nondim') + endif + if (CS%kdgl90_use_ebt_struct .or. CS%kdgl90_use_sqg_struct) then + CS%id_kdgl90_struct = register_diag_field('ocean_model', 'kdgl90_struct', diag%axesTl, Time, & + 'Vertical structure of GL90 diffusivity', 'nondim') + endif + + if ((CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) ) then CS%id_N2_u = register_diag_field('ocean_model', 'N2_u', diag%axesCui, Time, & 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', & 's-2', conversion=(US%L_to_Z*US%s_to_T)**2) @@ -1607,10 +1834,14 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & "If true, use a more robust estimate of the first mode wave speed as the "//& "starting point for iterations.", default=.true.) - call wave_speed_init(CS%wave_speed, use_ebt_mode=CS%Resoln_use_ebt, & + call get_param(param_file, mdl, "EBT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) + call wave_speed_init(CS%wave_speed, GV, use_ebt_mode=CS%Resoln_use_ebt, & mono_N2_depth=N2_filter_depth, remap_answer_date=remap_answer_date, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & - wave_speed_tol=wave_speed_tol) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, wave_speed_tol=wave_speed_tol) endif ! Leith parameters @@ -1664,10 +1895,15 @@ end subroutine VarMix_init subroutine VarMix_end(CS) type(VarMix_CS), intent(inout) :: CS - if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) & - deallocate(CS%ebt_struct) + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & + .or. CS%BS_EBT_power>0. .or. CS%khtr_use_ebt_struct) deallocate(CS%ebt_struct) + if (allocated(CS%sqg_struct)) deallocate(CS%sqg_struct) + if (allocated(CS%BS_struct)) deallocate(CS%BS_struct) + if (CS%khth_use_ebt_struct .or. CS%khth_use_sqg_struct) deallocate(CS%khth_struct) + if (CS%khtr_use_ebt_struct .or. CS%khtr_use_sqg_struct) deallocate(CS%khtr_struct) + if (CS%kdgl90_use_ebt_struct .or. CS%kdgl90_use_sqg_struct) deallocate(CS%kdgl90_struct) - if (CS%use_stored_slopes) then + if (CS%use_stored_slopes .or. CS%sqg_expo>0.0) then deallocate(CS%slope_x) deallocate(CS%slope_y) endif @@ -1737,14 +1973,14 @@ end subroutine VarMix_end !! \f] !! !! \todo Check this reference to Bob on/off paper. -!! The resolution function used in scaling diffusivities (Hallberg, 2010) is +!! The resolution function used in scaling diffusivities (\cite hallberg2013) is !! !! \f[ !! r(\Delta,L_d) = \frac{1}{1+(\alpha R)^p} !! \f] !! -!! The resolution function can be applied independently to thickness diffusion (module mom_thickness_diffuse), -!! tracer diffusion (mom_tracer_hordiff) lateral viscosity (mom_hor_visc). +!! The resolution function can be applied independently to thickness diffusion \(module mom_thickness_diffuse\), +!! tracer diffusion \(mom_tracer_hordiff\) lateral viscosity \(mom_hor_visc\). !! !! Robert Hallberg, 2013: Using a resolution function to regulate parameterizations of oceanic mesoscale eddy effects. !! Ocean Modelling, 71, pp 92-103. http://dx.doi.org/10.1016/j.ocemod.2013.08.007 @@ -1766,7 +2002,7 @@ end subroutine VarMix_end !! \section section_Vicbeck Visbeck diffusivity !! !! This module also calculates factors used in setting the thickness diffusivity similar to a Visbeck et al., 1997, -!! scheme. The factors are combined in mom_thickness_diffuse::thickness_diffuse() but calculated in this module. +!! scheme. The factors are combined in mom_thickness_diffuse::thickness_diffuse but calculated in this module. !! !! \f[ !! \kappa_h = \alpha_s L_s^2 S N diff --git a/src/parameterizations/lateral/MOM_load_love_numbers.F90 b/src/parameterizations/lateral/MOM_load_love_numbers.F90 index 3d573d894d..8faf3aafab 100644 --- a/src/parameterizations/lateral/MOM_load_love_numbers.F90 +++ b/src/parameterizations/lateral/MOM_load_love_numbers.F90 @@ -1452,16 +1452,18 @@ module MOM_load_love_numbers /), (/4, lmax+1/)) !< Load Love numbers !> \namespace mom_load_love_numbers +!! \section section_Love_numbers The Love numbers +!! !! This module serves the sole purpose of storing load Love number. The Love numbers are used for the spherical harmonic !! self-attraction and loading (SAL) calculation in MOM_self_attr_load module. This separate module ensures readability !! of the SAL module. !! !! Variable Love_Data stores the Love numbers up to degree 1440. From left to right: degree, h, l, and k. Data in this !! module is imported from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los Alamos -!! National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2022)]. The load Love numbers -!! are from Wang et al. (2012), which are in the center of mass of total Earth system reference frame (CM). When used, -!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) [Blewitt (2003)], -!! as in subroutine calc_love_scaling in MOM_tidal_forcing module. +!! National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. The load Love numbers +!! are from \cite Wang2012-2, which are in the center of mass of total Earth system reference frame (CM). When used, +!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) +!! [\cite Blewitt2003], as in subroutine calc_love_scaling in MOM_tidal_forcing module. !! !! References: !! @@ -1483,4 +1485,4 @@ module MOM_load_love_numbers !! for elastic Earth models PREM, iasp91, ak135, and modified models with refined crustal structure from Crust 2.0. !! Computers & Geosciences, 49, pp.190-199. !! https://doi.org/10.1016/j.cageo.2012.06.022 -end module MOM_load_love_numbers \ No newline at end of file +end module MOM_load_love_numbers diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 7f3403aef5..0d36ebf6d9 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -15,6 +15,7 @@ module MOM_mixed_layer_restrat use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_intrinsic_functions, only : cuberoot +use MOM_io, only : MOM_read_data use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_unit_scaling, only : unit_scale_type @@ -98,11 +99,15 @@ module MOM_mixed_layer_restrat real :: Kv_restrat !< A viscosity that sets a floor on the momentum mixing rate !! during restratification, rescaled into thickness-based !! units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] + logical :: MLD_grid !< If true, read a spacially varying field for MLD_decaying_Tfilt + logical :: Cr_grid !< If true, read a spacially varying field for Cr real, dimension(:,:), allocatable :: & MLD_filtered, & !< Time-filtered MLD [H ~> m or kg m-2] MLD_filtered_slow, & !< Slower time-filtered MLD [H ~> m or kg m-2] - wpup_filtered !< Time-filtered vertical momentum flux [H L T-2 ~> m2 s-2 or kg m-1 s-2] + wpup_filtered, & !< Time-filtered vertical momentum flux [H L T-2 ~> m2 s-2 or kg m-1 s-2] + MLD_Tfilt_space, & !< Spatially varying time scale for MLD filter [T ~> s] + Cr_space !< Spatially varying Cr coefficient [nondim] !>@{ !! Diagnostic identifier @@ -340,8 +345,8 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, ! Apply time filter (to remove diurnal cycle) if (CS%MLE_MLD_decay_time>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(h_MLD, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(h_MLD, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, unscale=GV%H_to_mks) endif aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) bFac = dt / ( dt + CS%MLE_MLD_decay_time ) @@ -357,8 +362,9 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, ! Apply slower time filter (to remove seasonal cycle) on already filtered MLD_fast if (CS%MLE_MLD_decay_time2>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered_slow, 'mixed_layer_restrat: MLD_filtered_slow', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(MLD_fast, 'mixed_layer_restrat: MLD fast', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(CS%MLD_filtered_slow, 'mixed_layer_restrat: MLD_filtered_slow', G%HI, & + haloshift=1, unscale=GV%H_to_mks) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD fast', G%HI, haloshift=1, unscale=GV%H_to_mks) endif aFac = CS%MLE_MLD_decay_time2 / ( dt + CS%MLE_MLD_decay_time2 ) bFac = dt / ( dt + CS%MLE_MLD_decay_time2 ) @@ -485,11 +491,11 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, endif if (CS%debug) then - call hchksum(h, 'mixed_layer_restrat: h', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=GV%H_to_m*US%s_to_T) - call hchksum(MLD_fast, 'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(h, 'mixed_layer_restrat: h', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, unscale=GV%H_to_m*US%s_to_T) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD', G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(Rml_av_fast, 'mixed_layer_restrat: rml', G%HI, haloshift=1, & - scale=GV%m_to_H*US%L_T_to_m_s**2) + unscale=GV%m_to_H*US%L_T_to_m_s**2) endif ! TO DO: @@ -698,7 +704,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) if (CS%id_uml > 0) then - do J=js,je ; do i=is-1,ie + do j=js,je ; do I=is-1,ie h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (mu(0.,0.)-mu(-.01,0.)) enddo ; enddo @@ -866,16 +872,16 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) if (CS%debug) then - call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(BLD, 'mle_Bodner: BLD', G%HI, haloshift=1, scale=US%Z_to_m) - call hchksum(h_MLD, 'mle_Bodner: h_MLD', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(BLD, 'mle_Bodner: BLD', G%HI, haloshift=1, unscale=US%Z_to_m) + call hchksum(h_MLD, 'mle_Bodner: h_MLD', G%HI, haloshift=1, unscale=GV%H_to_mks) if (associated(bflux)) & - call hchksum(bflux, 'mle_Bodner: bflux', G%HI, haloshift=1, scale=US%Z_to_m**2*US%s_to_T**3) - call hchksum(U_star_2d, 'mle_Bodner: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) + call hchksum(bflux, 'mle_Bodner: bflux', G%HI, haloshift=1, unscale=US%Z_to_m**2*US%s_to_T**3) + call hchksum(U_star_2d, 'mle_Bodner: u*', G%HI, haloshift=1, unscale=US%Z_to_m*US%s_to_T) call hchksum(CS%MLD_filtered, 'mle_Bodner: MLD_filtered 1', & - G%HI, haloshift=1, scale=GV%H_to_mks) + G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 1', & - G%HI, haloshift=1, scale=GV%H_to_mks) + G%HI, haloshift=1, unscale=GV%H_to_mks) endif ! Apply time filter to h_MLD (to remove diurnal cycle) to obtain "little h". @@ -887,11 +893,19 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d enddo ; enddo ! Calculate "big H", representative of the mixed layer depth, used in B22 formula (eq 27). - do j=js-1,je+1 ; do i=is-1,ie+1 - big_H(i,j) = rmean2ts(little_h(i,j), CS%MLD_filtered_slow(i,j), & - CS%MLD_growing_Tfilt, CS%MLD_decaying_Tfilt, dt) - CS%MLD_filtered_slow(i,j) = big_H(i,j) - enddo ; enddo + if (CS%MLD_grid) then + do j=js-1,je+1 ; do i=is-1,ie+1 + big_H(i,j) = rmean2ts(little_h(i,j), CS%MLD_filtered_slow(i,j), & + CS%MLD_growing_Tfilt, CS%MLD_Tfilt_space(i,j), dt) + CS%MLD_filtered_slow(i,j) = big_H(i,j) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + big_H(i,j) = rmean2ts(little_h(i,j), CS%MLD_filtered_slow(i,j), & + CS%MLD_growing_Tfilt, CS%MLD_decaying_Tfilt, dt) + CS%MLD_filtered_slow(i,j) = big_H(i,j) + enddo ; enddo + endif ! Estimate w'u' at h-points, with a floor to avoid division by zero later. if (allocated(tv%SpV_avg) .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then @@ -964,13 +978,13 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d endif if (CS%debug) then - call hchksum(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(CS%MLD_filtered,'mle_Bodner: MLD_filtered 2', & - G%HI, haloshift=1, scale=GV%H_to_mks) + G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 2', & - G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(wpup,'mle_Bodner: wpup', G%HI, haloshift=1, scale=US%L_to_m*GV%H_to_mks*US%s_to_T**2) + G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(wpup,'mle_Bodner: wpup', G%HI, haloshift=1, unscale=US%L_to_m*GV%H_to_mks*US%s_to_T**2) endif ! Calculate the average density in the "mixed layer". @@ -1034,10 +1048,10 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d enddo if (CS%debug) then - call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(vol_dt_avail,'mle_Bodner: vol_dt_avail', G%HI, haloshift=1, & - scale=US%L_to_m**2*GV%H_to_mks*US%s_to_T) - call hchksum(buoy_av,'mle_Bodner: buoy_av', G%HI, haloshift=1, scale=GV%m_to_H*US%L_T_to_m_s**2) + unscale=US%L_to_m**2*GV%H_to_mks*US%s_to_T) + call hchksum(buoy_av,'mle_Bodner: buoy_av', G%HI, haloshift=1, unscale=GV%m_to_H*US%L_T_to_m_s**2) endif ! U - Component @@ -1050,8 +1064,8 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d h_big = 0.5*( big_H(i,j) + big_H(i+1,j) ) ! H ~> m or kg m-3 grd_b = ( buoy_av(i+1,j) - buoy_av(i,j) ) * G%IdxCu(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 r_wpup = 2. / ( wpup(i,j) + wpup(i+1,j) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 - psi_mag = ( ( ( CS%Cr * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 - * ( ( h_big**2 ) * grd_b ) ) * r_wpup + psi_mag = ( ( ( (0.5*(CS%Cr_space(i,j) + CS%Cr_space(i+1,j))) * grid_dsd ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 + * ( absf * h_sml ) ) * ( ( h_big**2 ) * grd_b ) ) * r_wpup else ! There is no flux on land and no gradient at open boundary points. psi_mag = 0.0 endif @@ -1091,8 +1105,8 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d h_big = 0.5*( big_H(i,j) + big_H(i,j+1) ) ! H ~> m or kg m-3 grd_b = ( buoy_av(i,j+1) - buoy_av(i,j) ) * G%IdyCv(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 r_wpup = 2. / ( wpup(i,j) + wpup(i,j+1) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 - psi_mag = ( ( ( CS%Cr * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 - * ( ( h_big**2 ) * grd_b ) ) * r_wpup + psi_mag = ( ( ( (0.5*(CS%Cr_space(i,j) + CS%Cr_space(i,j+1))) * grid_dsd ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 + * ( absf * h_sml ) ) * ( ( h_big**2 ) * grd_b ) ) * r_wpup else ! There is no flux on land and no gradient at open boundary points. psi_mag = 0.0 endif @@ -1151,7 +1165,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d if (CS%id_lfbod > 0) call post_data(CS%id_lfbod, lf_bodner_diag, CS%diag) if (CS%id_uml > 0) then - do J=js,je ; do i=is-1,ie + do j=js,je ; do I=is-1,ie h_vel = 0.5*((htot(i,j) + htot(i+1,j)) + h_neglect) uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (mu(0.,0.)-mu(-.01,0.)) enddo ; enddo @@ -1549,6 +1563,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, ! This include declares and sets the variable "version". # include "version_variable.h" integer :: i, j + character(len=200) :: filename, inputdir, varname ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & @@ -1571,11 +1586,14 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, CS%MLE_MLD_stretch = -9.e9 CS%use_Stanley_ML = .false. CS%use_Bodner = .false. + CS%MLD_grid = .false. + CS%Cr_grid = .false. call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231, do_not_log=.true.) + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") call openParameterBlock(param_file,'MLE') ! Prepend MLE% to all parameters if (GV%nkml==0) then call get_param(param_file, mdl, "USE_BODNER23", CS%use_Bodner, & @@ -1584,7 +1602,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, default=.false.) endif if (CS%use_Bodner) then - call get_param(param_file, mdl, "CR", CS%CR, & + call get_param(param_file, mdl, "CR", CS%Cr, & "The efficiency coefficient in eq 27 of Bodner et al., 2023.", & units="nondim", default=0.0) call get_param(param_file, mdl, "BODNER_NSTAR", CS%Nstar, & @@ -1638,6 +1656,34 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "USE_STANLEY_TVAR", CS%use_Stanley_ML, & "If true, turn on Stanley SGS T variance parameterization "// & "in ML restrat code.", default=.false.) + call get_param(param_file, mdl, "USE_CR_GRID", CS%Cr_grid, & + "If true, read in a spatially varying Cr field.", default=.false.) + call get_param(param_file, mdl, "USE_MLD_GRID", CS%MLD_grid, & + "If true, read in a spatially varying MLD_decaying_Tfilt field.", default=.false.) + if (CS%MLD_grid) then + call get_param(param_file, mdl, "MLD_TFILT_FILE", filename, & + "The path to the file containing the MLD_decaying_Tfilt fields.", & + default="") + call get_param(param_file, mdl, "MLD_TFILT_VAR", varname, & + "The variable name for MLD_decaying_Tfilt field.", & + default="MLD_tfilt") + filename = trim(inputdir) // "/" // trim(filename) + allocate(CS%MLD_Tfilt_space(G%isd:G%ied,G%jsd:G%jed), source=0.0) + call MOM_read_data(filename, varname, CS%MLD_Tfilt_space, G%domain, scale=US%s_to_T) + call pass_var(CS%MLD_Tfilt_space, G%domain) + endif + allocate(CS%Cr_space(G%isd:G%ied,G%jsd:G%jed), source=CS%Cr) + if (CS%Cr_grid) then + call get_param(param_file, mdl, "CR_FILE", filename, & + "The path to the file containing the Cr fields.", & + default="") + call get_param(param_file, mdl, "CR_VAR", varname, & + "The variable name for Cr field.", & + default="Cr") + filename = trim(inputdir) // "/" // trim(filename) + call MOM_read_data(filename, varname, CS%Cr_space, G%domain) + call pass_var(CS%Cr_space, G%domain) + endif call closeParameterBlock(param_file) ! The remaining parameters do not have MLE% prepended call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & "If true, the MLE parameterization will use the mixed-layer "//& @@ -1660,7 +1706,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "mesoscale eddy kinetic energy to the large-scale "//& "geostrophic kinetic energy or 1 plus the square of the "//& "grid spacing over the deformation radius, as detailed "//& - "by Fox-Kemper et al. (2010)", units="nondim", default=0.0) + "by Fox-Kemper et al. (2011)", units="nondim", default=0.0) ! These parameters are only used in the OM4-era version of Fox-Kemper call get_param(param_file, mdl, "USE_STANLEY_ML", CS%use_Stanley_ML, & "If true, turn on Stanley SGS T variance parameterization "// & @@ -1706,7 +1752,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & "Density difference used to detect the mixed-layer "//& "depth used for the mixed-layer eddy parameterization "//& - "by Fox-Kemper et al. (2010)", units="kg/m3", default=0.03, scale=US%kg_m3_to_R) + "by Fox-Kemper et al. (2011)", units="kg/m3", default=0.03, scale=US%kg_m3_to_R) endif call get_param(param_file, mdl, "MLE_TAIL_DH", CS%MLE_tail_dh, & "Fraction by which to extend the mixed-layer restratification "//& @@ -1907,10 +1953,10 @@ logical function test_answer(verbose, u, u_true, label, tol) if (abs(u - u_true) > tolerance) test_answer = .true. if (test_answer .or. verbose) then if (test_answer) then - print '(3(a,1pe24.16),x,a,x,a)','computed =',u,' correct =',u_true, & + print '(3(a,1pe24.16),1x,a,1x,a)','computed =',u,' correct =',u_true, & ' err=',u-u_true,' < wrong',label else - print '(2(a,1pe24.16),x,a)','computed =',u,' correct =',u_true,label + print '(2(a,1pe24.16),1x,a)','computed =',u,' correct =',u_true,label endif endif @@ -1921,29 +1967,29 @@ end function test_answer !! \section section_mle Mixed-layer eddy parameterization module !! !! The subroutines in this module implement a parameterization of unresolved viscous -!! mixed layer restratification of the mixed layer as described in Fox-Kemper et -!! al., 2008, and whose impacts are described in Fox-Kemper et al., 2011. +!! mixed layer restratification of the mixed layer as described in \cite fox-kemper2008, +!! and whose impacts are described in \cite fox-kemper2011. !! This is derived in part from the older parameterization that is described in -!! Hallberg (Aha Hulikoa, 2003), which this new parameterization surpasses, which -!! in turn is based on the sub-inertial mixed layer theory of Young (JPO, 1994). +!! \cite Hallberg2003, which this new parameterization surpasses, which +!! in turn is based on the sub-inertial mixed layer theory of \cite Young1994. !! There is no net horizontal volume transport due to this parameterization, and -!! no direct effect below the mixed layer. A revised of the parameterization by -!! Bodner et al., 2023, is also available as an option. +!! no direct effect below the mixed layer. A revised version of the parameterization by +!! \cite Bodner2023 is also available as an option. !! !! This parameterization sets the restratification timescale to agree with !! high-resolution studies of mixed layer restratification. !! -!! The run-time parameter FOX_KEMPER_ML_RESTRAT_COEF is a non-dimensional number of +!! The run-time parameter FOX_KEMPER_ML_RESTRAT_COEF is a non-dimensional number of !! order a few tens, proportional to the ratio of the deformation radius or the -!! grid scale (whichever is smaller to the dominant horizontal length-scale of the +!! grid scale (whichever is smaller) to the dominant horizontal length-scale of the !! sub-meso-scale mixed layer instabilities. !! !! \subsection section_mle_nutshell "Sub-meso" in a nutshell !! !! The parameterization is colloquially referred to as "sub-meso". !! -!! The original Fox-Kemper et al., (2008b) paper proposed a quasi-Stokes -!! advection described by the stream function (eq. 5 of Fox-Kemper et al., 2011): +!! The original \cite fox-kemper2008-2 paper proposed a quasi-Stokes +!! advection described by the stream function (eq. 5 of \cite fox-kemper2011): !! \f[ !! {\bf \Psi}_o = C_e \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} }{ |f| } \mu(z) !! \f] @@ -1957,7 +2003,7 @@ end function test_answer !! \f$ \nabla \bar{b} \f$ is a depth mean buoyancy gradient averaged over the mixed layer. !! !! For use in coarse-resolution models, an upscaling of the buoyancy gradients and adaption for the equator -!! leads to the following parameterization (eq. 6 of Fox-Kemper et al., 2011): +!! leads to the following parameterization (eq. 6 of \cite fox-kemper2011): !! \f[ !! {\bf \Psi} = C_e \Gamma_\Delta \frac{\Delta s}{l_f} \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} } !! { \sqrt{ f^2 + \tau^{-2}} } \mu(z) @@ -1967,14 +2013,15 @@ end function test_answer !! \f$ \tau \f$ is a time-scale for mixing momentum across the mixed layer. !! \f$ l_f \f$ is thought to be of order hundreds of meters. !! -!! The upscaling factor \f$ \frac{\Delta s}{l_f} \f$ can be a global constant, model parameter FOX_KEMPER_ML_RESTRAT, -!! so that in practice the parameterization is: +!! The upscaling factor \f$ \frac{\Delta s}{l_f} \f$ can be a global constant, model parameter +!! FOX_KEMPER_ML_RESTRAT, so that in practice the parameterization is: !! \f[ !! {\bf \Psi} = C_e \Gamma_\Delta \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} }{ \sqrt{ f^2 + \tau^{-2}} } \mu(z) !! \f] !! with non-unity \f$ \Gamma_\Delta \f$. !! !! \f$ C_e \f$ is hard-coded as 0.0625. \f$ \tau \f$ is calculated from the surface friction velocity \f$ u^* \f$. +!! !! \todo Explain expression for momentum mixing time-scale. !! !! | Symbol | Module parameter | @@ -2013,7 +2060,7 @@ end function test_answer !! available parameters. !! MLE_USE_PBL_MLD must be True to use the B23 modification. !! -!! Bodner et al., 2023, (B23) use an expression for the frontal width which changes the scaling from \f$ H^2 \f$ +!! \cite Bodner2023, (B23) use an expression for the frontal width which changes the scaling from \f$ H^2 \f$ !! to \f$ h H^2 \f$: !! \f[ !! {\bf \Psi} = C_r \frac{\Delta s |f| \bar{h} \bar{H}^2 \nabla \bar{b} \times \hat{\bf z} } @@ -2058,7 +2105,7 @@ end function test_answer !! | \f$ \tau_{h+} \f$ | MLE\%BLD_GROWING_TFILTER | !! | \f$ \tau_{h-} \f$ | MLE\%BLD_DECAYING_TFILTER | !! | \f$ \tau_{H+} \f$ | MLE\%MLD_GROWING_TFILTER | -!! | \f$ \tau_{H-} \f$ | MLE\%BLD_DECAYING_TFILTER | +!! | \f$ \tau_{H-} \f$ | MLE\%MLD_DECAYING_TFILTER | !! !! \subsection section_mle_ref References !! diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index e7f8a73ab2..f72b6f513e 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -245,19 +245,22 @@ end subroutine SAL_end !> \namespace self_attr_load !! +!! \section section_SAL Self attraction and loading +!! !! This module contains methods to calculate self-attraction and loading (SAL) as a function of sea surface height (SSH) !! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or !! storm surges, but the effect applies to all motions. !! -!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied (Accad and Pekeris 1978) and the SAL is simply -!! a fraction (set by SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For tides, the scalar -!! approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, -!! Arbic et al. (2004)]. +!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied (\cite Accad1978) and the SAL is simply +!! a fraction (set by SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH. +!! For tides, the scalar approximation can also be used to iterate the SAL to convergence [see +!! USE_PREVIOUS_TIDES in MOM_tidal_forcing, \cite Arbic2004]. !! -!! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate SAL. -!! Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set by -!! SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean -!! developed by Los Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. +!! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate +!! SAL. Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is +!! set by SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across +!! Scales (MPAS)-Ocean +!! developed by Los Alamos National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. !! !! References: !! diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index 26258e6b8e..4f9cee03aa 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -334,6 +334,8 @@ end function order2index !> \namespace mom_spherical_harmonics !! +!! \section section_spherical_harmonics Spherical harmonics +!! !! This module contains the subroutines to calculate spherical harmonic transforms (SHT), namely, forward transform !! of a two-dimensional field into a given number of spherical harmonic modes and its inverse transform. This module !! is primarily used to but not limited to calculate self-attraction and loading (SAL) term, which is mostly relevant to @@ -341,8 +343,8 @@ end function order2index !! Currently, the transforms are for t-cell fields only. !! !! This module is stemmed from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los -!! Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. The algorithm -!! for forward and inverse transforms loosely follows Schaeffer (2013). +!! Alamos National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. The algorithm +!! for forward and inverse transforms loosely follows \cite Schaeffer2013. !! !! In forward transform, a two-dimensional physical field can be projected into a series of spherical harmonics. The !! spherical harmonic coefficient of degree n and order m for a field \f$f(\theta, \phi)\f$ is calculated as follows: @@ -359,7 +361,7 @@ end function order2index !! \f[ !! f^m_n = \sum^{Nj}_{0}\sum^{Ni}_{0}f(i,j)Y^m_n(i,j)A(i,j)/r_e^2 !! \f] -!! where $A$ is the area of the cell and $r_e$ is the radius of the Earth. +!! where \f$A\f$ is the area of the cell and \f$r_e\f$ is the radius of the Earth. !! !! In inverse transform, the first N degree spherical harmonic coefficients are used to reconstruct a two-dimensional !! physical field: @@ -372,10 +374,10 @@ end function order2index !! array vectorization. !! !! The maximum degree of the spherical harmonics is a runtime parameter and the maximum used by all SHT applications. -!! At the moment, it is only decided by SAL_HARMONICS_DEGREE. +!! At the moment, it is only decided by SAL_HARMONICS_DEGREE. !! -!! The forward transforms involve a global summation. Runtime flag SHT_REPRODUCING_SUM controls whether this is done -!! in a bit-wise reproducing way or not. +!! The forward transforms involve a global summation. Runtime flag SHT_REPRODUCING_SUM controls +!! whether this is done in a bit-wise reproducing way or not. !! !! References: !! diff --git a/src/parameterizations/lateral/MOM_streaming_filter.F90 b/src/parameterizations/lateral/MOM_streaming_filter.F90 new file mode 100644 index 0000000000..a91f6661f2 --- /dev/null +++ b/src/parameterizations/lateral/MOM_streaming_filter.F90 @@ -0,0 +1,119 @@ +!> Streaming band-pass filter for detecting the instantaneous tidal signals in the simulation +module MOM_streaming_filter + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL +use MOM_hor_index, only : hor_index_type +use MOM_time_manager, only : time_type, time_type_to_real +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public Filt_register, Filt_accum + +#include + +!> The control structure for storing the filter infomation of a particular field +type, public :: Filter_CS ; private + real :: a, & !< Parameter that determines the bandwidth [nondim] + om, & !< Target frequency of the filter [T-1 ~> s-1] + old_time = -1.0 !< The time of the previous accumulating step [T ~> s] + real, allocatable, dimension(:,:) :: s1, & !< Dummy variable [A] + u1 !< Filtered data [A] + !>@{ Lower and upper bounds of input data + integer :: is, ie, js, je + !>@} +end type Filter_CS + +contains + +!> This subroutine registers each of the fields to be filtered. +subroutine Filt_register(a, om, grid, HI, CS) + real, intent(in) :: a !< Parameter that determines the bandwidth [nondim] + real, intent(in) :: om !< Target frequency of the filter [T-1 ~> s-1] + character(len=*), intent(in) :: grid !< Horizontal grid location: h, u, or v + type(hor_index_type), intent(in) :: HI !< Horizontal index type structure + type(Filter_CS), intent(out) :: CS !< Control structure for the current field + + ! Local variables + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + if (a <= 0.0) call MOM_error(FATAL, "MOM_streaming_filter: bandwidth <= 0") + if (om <= 0.0) call MOM_error(FATAL, "MOM_streaming_filter: target frequency <= 0") + + CS%a = a + CS%om = om + + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + + select case (trim(grid)) + case ('h') + allocate(CS%s1(isd:ied,jsd:jed)) ; CS%s1(:,:) = 0.0 + allocate(CS%u1(isd:ied,jsd:jed)) ; CS%u1(:,:) = 0.0 + CS%is = isd ; CS%ie = ied ; CS%js = jsd ; CS%je = jed + case ('u') + allocate(CS%s1(IsdB:IedB,jsd:jed)) ; CS%s1(:,:) = 0.0 + allocate(CS%u1(IsdB:IedB,jsd:jed)) ; CS%u1(:,:) = 0.0 + CS%is = IsdB ; CS%ie = IedB ; CS%js = jsd ; CS%je = jed + case ('v') + allocate(CS%s1(isd:ied,JsdB:JedB)) ; CS%s1(:,:) = 0.0 + allocate(CS%u1(isd:ied,JsdB:JedB)) ; CS%u1(:,:) = 0.0 + CS%is = isd ; CS%ie = ied ; CS%js = JsdB ; CS%je = JedB + case default + call MOM_error(FATAL, "MOM_streaming_filter: horizontal grid not supported") + end select + +end subroutine Filt_register + +!> This subroutine timesteps the filter equations. It takes model output u at the current time step as the input, +!! and returns tidal signal u1 as the output, which is the solution of a set of two ODEs (the filter equations). +subroutine Filt_accum(u, u1, Time, US, CS) + real, dimension(:,:), pointer, intent(out) :: u1 !< Output of the filter [A] + type(time_type), intent(in) :: Time !< The current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Filter_CS), target, intent(inout) :: CS !< Control structure of the MOM_streaming_filter module + real, dimension(CS%is:CS%ie,CS%js:CS%je), intent(in) :: u !< Input into the filter [A] + + ! Local variables + real :: now, & !< The current model time [T ~> s] + dt, & !< Time step size for the filter equations [T ~> s] + c1, c2 !< Coefficients for the filter equations [nondim] + integer :: i, j, is, ie, js, je + + now = US%s_to_T * time_type_to_real(Time) + is = CS%is ; ie = CS%ie ; js = CS%js ; je = CS%je + + ! Initialize u1 + if (CS%old_time < 0.0) then + CS%old_time = now + CS%u1(:,:) = u(:,:) + endif + + dt = now - CS%old_time + CS%old_time = now + + ! Timestepping + c1 = CS%om * dt + c2 = 1.0 - CS%a * c1 + + do j=js,je ; do i=is,ie + CS%s1(i,j) = c1 * CS%u1(i,j) + CS%s1(i,j) + CS%u1(i,j) = -c1 * (CS%s1(i,j) - CS%a * u(i,j)) + c2 * CS%u1(i,j) + enddo; enddo + u1 => CS%u1 + +end subroutine Filt_accum + +!> \namespace streaming_filter +!! +!! This module detects instantaneous tidal signals in the model output using a set of coupled ODEs (the filter +!! equations), given the target frequency (om) and the bandwidth parameter (a) of the filter. At each timestep, +!! the filter takes model output (u) as the input and returns a time series consisting of sinusoidal motions (u1) +!! near its target frequency. The filtered tidal signals can be used to parameterize frequency-dependent drag, or +!! to detide the model output. See Xu & Zaron (2024) for detail. +!! +!! Reference: Xu, C., & Zaron, E. D. (2024). Detecting instantaneous tidal signals in ocean models utilizing +!! streaming band-pass filters. Journal of Advances in Modeling Earth Systems. Under review. + +end module MOM_streaming_filter + diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index d42d9600ce..daea75e73d 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -179,7 +179,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp ! to layer centers [L2 T-1 ~> m2 s-1] real :: KH_v_lay(SZI_(G),SZJ_(G)) ! Diagnostic of isopycnal height diffusivities at v-points averaged ! to layer centers [L2 T-1 ~> m2 s-1] - logical :: use_VarMix, Resoln_scaled, Depth_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck + logical :: use_VarMix, Resoln_scaled, Depth_scaled, use_stored_slopes, khth_use_vert_struct, use_Visbeck logical :: use_QG_Leith integer :: i, j, k, is, ie, js, je, nz @@ -198,7 +198,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif use_VarMix = .false. ; Resoln_scaled = .false. ; use_stored_slopes = .false. - khth_use_ebt_struct = .false. ; use_Visbeck = .false. ; use_QG_Leith = .false. + khth_use_vert_struct = .false. ; use_Visbeck = .false. ; use_QG_Leith = .false. Depth_scaled = .false. if (VarMix%use_variable_mixing) then @@ -206,7 +206,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp Resoln_scaled = VarMix%Resoln_scaled_KhTh Depth_scaled = VarMix%Depth_scaled_KhTh use_stored_slopes = VarMix%use_stored_slopes - khth_use_ebt_struct = VarMix%khth_use_ebt_struct + khth_use_vert_struct = allocated(VarMix%khth_struct) use_Visbeck = VarMix%use_Visbeck use_QG_Leith = VarMix%use_QG_Leith_GM if (allocated(VarMix%cg1)) cg1 => VarMix%cg1 @@ -221,7 +221,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp (dt * ((G%IdxCu(I,j)*G%IdxCu(I,j)) + (G%IdyCu(I,j)*G%IdyCu(I,j)))) enddo ; enddo !$OMP parallel do default(shared) - do j=js-1,je ; do I=is,ie + do J=js-1,je ; do i=is,ie KH_v_CFL(i,J) = (0.25*CS%max_Khth_CFL) / & (dt * ((G%IdxCv(i,J)*G%IdxCv(i,J)) + (G%IdyCv(i,J)*G%IdyCv(i,J)))) enddo ; enddo @@ -298,10 +298,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp KH_u(I,j,1) = min(KH_u_CFL(I,j), Khth_loc_u(I,j)) enddo ; enddo - if (khth_use_ebt_struct) then + if (khth_use_vert_struct) then !$OMP do do K=2,nz+1 ; do j=js,je ; do I=is-1,ie - KH_u(I,j,K) = KH_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + KH_u(I,j,K) = KH_u(I,j,1) * 0.5 * ( VarMix%khth_struct(i,j,k-1) + VarMix%khth_struct(i+1,j,k-1) ) enddo ; enddo ; enddo else !$OMP do @@ -394,10 +394,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo endif - if (khth_use_ebt_struct) then + if (khth_use_vert_struct) then !$OMP do do K=2,nz+1 ; do J=js-1,je ; do i=is,ie - KH_v(i,J,K) = KH_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + KH_v(i,J,K) = KH_v(i,J,1) * 0.5 * ( VarMix%khth_struct(i,j,k-1) + VarMix%khth_struct(i,j+1,k-1) ) enddo ; enddo ; enddo else !$OMP do @@ -426,7 +426,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%MEKE_GEOMETRIC) then if (CS%MEKE_GEOM_answer_date < 20190101) then !$OMP do - do j=js,je ; do I=is,ie + do j=js,je ; do i=is,ie ! This does not give bitwise rotational symmetry. MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & (0.25*(VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j) + & @@ -435,7 +435,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo else !$OMP do - do j=js,je ; do I=is,ie + do j=js,je ; do i=is,ie ! With the additional parentheses this gives bitwise rotational symmetry. MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & (0.25*((VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j)) + & @@ -463,23 +463,23 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%debug) then call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, & - scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + unscale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) call uvchksum("Kh_[uv]_CFL", Kh_u_CFL, Kh_v_CFL, G%HI, haloshift=0, & - scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + unscale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) if (Resoln_scaled) then call uvchksum("Res_fn_[uv]", VarMix%Res_fn_u, VarMix%Res_fn_v, G%HI, haloshift=0, & - scale=1.0, scalar_pair=.true.) + unscale=1.0, scalar_pair=.true.) endif call uvchksum("int_slope_[uv]", int_slope_u, int_slope_v, G%HI, haloshift=0) - call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, unscale=GV%H_to_m) + call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, unscale=US%Z_to_m) if (use_stored_slopes) then call uvchksum("VarMix%slope_[xy]", VarMix%slope_x, VarMix%slope_y, & - G%HI, haloshift=0, scale=US%Z_to_L) + G%HI, haloshift=0, unscale=US%Z_to_L) endif if (associated(tv%eqn_of_state)) then - call hchksum(tv%T, "thickness_diffuse T", G%HI, haloshift=1, scale=US%C_to_degC) - call hchksum(tv%S, "thickness_diffuse S", G%HI, haloshift=1, scale=US%S_to_ppt) + call hchksum(tv%T, "thickness_diffuse T", G%HI, haloshift=1, unscale=US%C_to_degC) + call hchksum(tv%S, "thickness_diffuse S", G%HI, haloshift=1, unscale=US%S_to_ppt) endif endif @@ -588,10 +588,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%debug) then call uvchksum("thickness_diffuse [uv]hD", uhD, vhD, & - G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + G%HI, haloshift=0, unscale=GV%H_to_m*US%L_to_m**2*US%s_to_T) call uvchksum("thickness_diffuse [uv]htr", uhtr, vhtr, & - G%HI, haloshift=0, scale=US%L_to_m**2*GV%H_to_m) - call hchksum(h, "thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) + G%HI, haloshift=0, unscale=US%L_to_m**2*GV%H_to_m) + call hchksum(h, "thickness_diffuse h", G%HI, haloshift=0, unscale=GV%H_to_m) endif end subroutine thickness_diffuse @@ -1041,10 +1041,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (present_slope_x) then Slope = slope_x(I,j,k) else - Slope = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%OBCmaskCu(I,j) + Slope = ((e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j)) * G%OBCmaskCu(I,j) endif if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - Sfn_unlim_u(I,K) = ((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) + Sfn_unlim_u(I,K) = -(KH_u(I,j,K)*G%dy_Cu(I,j))*Slope dzN2_u(I,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) @@ -1361,10 +1361,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (present_slope_y) then Slope = slope_y(i,J,k) else - Slope = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%OBCmaskCv(i,J) + Slope = ((e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J)) * G%OBCmaskCv(i,J) endif if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - Sfn_unlim_v(i,K) = ((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) + Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) dzN2_v(i,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) @@ -1590,11 +1590,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif if (CS%debug) then - call hchksum(MEKE%GM_src, 'MEKE%GM_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) - call uvchksum("KH_[uv]", Kh_u, Kh_v, G%HI, scale=US%L_to_m**2*US%s_to_T, & + call hchksum(MEKE%GM_src, 'MEKE%GM_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call uvchksum("KH_[uv]", Kh_u, Kh_v, G%HI, unscale=US%L_to_m**2*US%s_to_T, & scalar_pair=.true.) - call uvchksum("Slope_[xy]_PE", Slope_x_PE, Slope_y_PE, G%HI, scale=US%Z_to_L) - call uvchksum("hN2_[xy]_PE", hN2_x_PE, hN2_y_PE, G%HI, scale=GV%H_to_mks*US%L_to_Z**2*US%s_to_T**2, & + call uvchksum("Slope_[xy]_PE", Slope_x_PE, Slope_y_PE, G%HI, unscale=US%Z_to_L) + call uvchksum("hN2_[xy]_PE", hN2_x_PE, hN2_y_PE, G%HI, unscale=GV%H_to_mks*US%L_to_Z**2*US%s_to_T**2, & scalar_pair=.true.) endif endif ; endif @@ -2452,19 +2452,19 @@ end subroutine thickness_diffuse_end !! to the potential density slope !! \f[ !! \vec{\psi} = - \kappa_h \frac{\nabla_z \rho}{\partial_z \rho} -!! = \frac{g\kappa_h}{\rho_o} \frac{\nabla \rho}{N^2} = \kappa_h \frac{M^2}{N^2} +!! = \frac{g\kappa_h}{\rho_o} \frac{\nabla \rho}{N^2} = -\kappa_h \frac{M^2}{N^2} !! \f] !! but for robustness the scheme is implemented as !! \f[ -!! \vec{\psi} = \kappa_h \frac{M^2}{\sqrt{N^4 + M^4}} +!! \vec{\psi} = -\kappa_h \frac{M^2}{\sqrt{N^4 + M^4}} !! \f] -!! since the quantity \f$\frac{M^2}{\sqrt{N^2 + M^2}}\f$ is bounded between $-1$ and $1$ and does not change sign +!! since the quantity \f$\frac{M^2}{\sqrt{N^4 + M^4}}\f$ is bounded between $-1$ and $1$ and does not change sign !! if \f$N^2<0\f$. !! -!! Optionally, the method of Ferrari et al, 2010, can be used to obtain the streamfunction which solves the +!! Optionally, the method of \cite ferrari2010, can be used to obtain the streamfunction which solves the !! vertically elliptic equation: !! \f[ -!! \gamma_F \partial_z c^2 \partial_z \psi - N_*^2 \psi = ( 1 + \gamma_F ) \kappa_h N_*^2 \frac{M^2}{\sqrt{N^4+M^4}} +!! \gamma_F \partial_z c^2 \partial_z \psi - N_*^2 \psi = -( 1 + \gamma_F ) \kappa_h N_*^2 \frac{M^2}{\sqrt{N^4+M^4}} !! \f] !! which recovers the previous streamfunction relation in the limit that \f$ c \rightarrow 0 \f$. !! Here, \f$c=\max(c_{min},c_g)\f$ is the maximum of either \f$c_{min}\f$ and either the first baroclinic mode @@ -2479,7 +2479,7 @@ end subroutine thickness_diffuse_end !! \f$ r(\Delta x,L_d) \f$ is a function of the local resolution (ratio of grid-spacing, \f$\Delta x\f$, !! to deformation radius, \f$L_d\f$). The length \f$L_s\f$ is provided by the mom_lateral_mixing_coeffs module !! (enabled with USE_VARIABLE_MIXING=True and the term \f$\f$ is the vertical average slope -!! times the buoyancy frequency prescribed by Visbeck et al., 1996. +!! times the buoyancy frequency prescribed by \cite visbeck1996. !! !! The result of the above expression is subsequently bounded by minimum and maximum values, including an upper !! diffusivity consistent with numerical stability (\f$ \kappa_{cfl} \f$ is calculated internally). diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 1cd8a45a78..177becf84f 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -9,6 +9,8 @@ module MOM_tidal_forcing use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, & + only : HA_init, HA_register, harmonic_analysis_CS use MOM_io, only : field_exists, file_exists, MOM_read_data use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) use MOM_unit_scaling, only : unit_scale_type @@ -231,12 +233,13 @@ end subroutine nodal_fu !! while fields like the background viscosities are 2-D arrays. !! ALLOC is a macro defined in MOM_memory.h for allocate or nothing with !! static memory. -subroutine tidal_forcing_init(Time, G, US, param_file, CS) +subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control structure + type(harmonic_analysis_CS), optional, intent(out) :: HA_CS !< Control structure for harmonic analysis ! Local variables real, dimension(SZI_(G), SZJ_(G)) :: & @@ -251,6 +254,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) logical :: use_M2, use_S2, use_N2, use_K2, use_K1, use_O1, use_P1, use_Q1 logical :: use_MF, use_MM logical :: tides ! True if a tidal forcing is to be used. + logical :: HA_ssh, HA_ubt, HA_vbt ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. @@ -523,6 +527,19 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) enddo endif + if (present(HA_CS)) then + call HA_init(Time, US, param_file, CS%time_ref, CS%nc, CS%freq, CS%phase0, CS%const_name, HA_CS) + call get_param(param_file, mdl, "HA_SSH", HA_ssh, & + "If true, perform harmonic analysis of sea serface height.", default=.false.) + if (HA_ssh) call HA_register('ssh', 'h', HA_CS) + call get_param(param_file, mdl, "HA_UBT", HA_ubt, & + "If true, perform harmonic analysis of zonal barotropic velocity.", default=.false.) + if (HA_ubt) call HA_register('ubt', 'u', HA_CS) + call get_param(param_file, mdl, "HA_VBT", HA_vbt, & + "If true, perform harmonic analysis of meridional barotropic velocity.", default=.false.) + if (HA_vbt) call HA_register('vbt', 'v', HA_CS) + endif + id_clock_tides = cpu_clock_id('(Ocean tides)', grain=CLOCK_MODULE) end subroutine tidal_forcing_init @@ -727,6 +744,8 @@ end subroutine tidal_forcing_end !> \namespace tidal_forcing !! +!! \section section_tides Tidal forcing +!! !! Code by Robert Hallberg, August 2005, based on C-code by Harper !! Simmons, February, 2003, in turn based on code by Brian Arbic. !! @@ -745,14 +764,14 @@ end subroutine tidal_forcing_end !! !! In addition, approaches to calculate self-attraction and loading !! due to tides (harmonics of astronomical forcing frequencies) -!! are provided. TIDAL_SAL_FROM_FILE can be set to read the phase and -!! amplitude of the tidal SAL. USE_PREVIOUS_TIDES may be useful in +!! are provided. TIDAL_SAL_FROM_FILE can be set to read the phase and +!! amplitude of the tidal SAL. USE_PREVIOUS_TIDES may be useful in !! combination with the scalar approximation to iterate the SAL to -!! convergence (for details, see Arbic et al., 2004, DSR II). With -!! TIDAL_SAL_FROM_FILE or USE_PREVIOUS_TIDES, a list of input files -!! must be provided to describe each constituent's properties from +!! convergence (for details, see \cite Arbic2004). With +!! TIDAL_SAL_FROM_FILE or USE_PREVIOUS_TIDES, a list of input +!! files must be provided to describe each constituent's properties from !! a previous solution. The online SAL calculations that are functions !! of SSH (rather should be bottom pressure anmoaly), either a scalar !! approximation or with spherical harmonic transforms, are located in -!! MOM_self_attr_load. +!! MOM_self_attr_load. end module MOM_tidal_forcing diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 0f4b50237e..0dfead633c 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -23,6 +23,7 @@ module MOM_ALE_sponge use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer use MOM_interpolate, only : init_external_field, get_external_field_info, time_interp_external_init use MOM_interpolate, only : external_field +use MOM_io, only : axis_info use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping use MOM_spatial_means, only : global_i_mean use MOM_time_manager, only : time_type @@ -86,6 +87,7 @@ module MOM_ALE_sponge character(len=:), allocatable :: name !< The name of the input field character(len=:), allocatable :: long_name !< The long name of the input field character(len=:), allocatable :: unit !< The unit of the input field + type(axis_info), allocatable :: axes_data(:) !< Axis types for the input field end type p2d !> ALE sponge control structure @@ -188,6 +190,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, logical :: data_h_to_Z logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then @@ -212,16 +215,17 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, default=.false.) call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & - "This sets the reconstruction scheme used "//& - " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) + call get_param(param_file, mdl, "SPONGE_REMAPPING_SCHEME", remapScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all SPONGE variables.", default=remapScheme) + !This default should be from REMAP_BOUNDARY_EXTRAP call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & - "When defined, a proper high-order reconstruction "//& - "scheme is used within boundary cells rather "//& - "than PCM. E.g., if PPM is used for remapping, a "//& - "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "SPONGE_BOUNDARY_EXTRAP", bndExtrapolation, & + "If true, values at the interfaces of SPONGE boundary cells are "//& + "extrapolated instead of piecewise constant", default=bndExtrapolation) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -232,6 +236,10 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) + call get_param(param_file, mdl, "SPONGE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ALE sponge. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& @@ -282,6 +290,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%remap_answer_date) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & @@ -460,12 +469,14 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I character(len=40) :: mdl = "MOM_sponge" ! This module's name. real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [T-1 ~> s-1] + real :: dz_neglect, dz_neglect_edge ! Negligible layer extents [Z ~> m] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=64) :: remapScheme logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: i, j, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then @@ -485,15 +496,16 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I "Apply sponges in u and v, in addition to tracers.", & default=.false.) call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & - "This sets the reconstruction scheme used "//& - " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) + call get_param(param_file, mdl, "SPONGE_REMAPPING_SCHEME", remapScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all SPONGE variables.", default=remapScheme) + !This default should be from REMAP_BOUNDARY_EXTRAP call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & - "When defined, a proper high-order reconstruction "//& - "scheme is used within boundary cells rather "//& - "than PCM. E.g., if PPM is used for remapping, a "//& - "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "SPONGE_BOUNDARY_EXTRAP", bndExtrapolation, & + "If true, values at the interfaces of SPONGE boundary cells are "//& + "extrapolated instead of piecewise constant", default=bndExtrapolation) call get_param(param_file, mdl, "VARYING_SPONGE_MASK_THICKNESS", CS%varying_input_dz_mask, & "An input file thickness below which the target values with "//& "time-varying sponges are replaced by the value above.", & @@ -508,6 +520,10 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date) + call get_param(param_file, mdl, "SPONGE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ALE sponge. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& @@ -546,8 +562,19 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I call sum_across_PEs(total_sponge_cols) ! Call the constructor for remapping control structure + if (CS%remap_answer_date >= 20190101) then + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + elseif (GV%Boussinesq) then + dz_neglect = US%m_to_Z*1.0e-30 ; dz_neglect_edge = US%m_to_Z*1.0e-10 + elseif (GV%semi_Boussinesq) then + dz_neglect = GV%kg_m2_to_H*GV%H_to_Z*1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z*1.0e-10 + else + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + endif call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & - answer_date=CS%remap_answer_date) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%remap_answer_date, & + h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.", like_default=.true.) if (CS%sponge_uv) then @@ -770,7 +797,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, CS%Ref_val(CS%fldno)%long_name = long_name CS%Ref_val(CS%fldno)%unit = unit fld_sz(1:4) = -1 - call get_external_field_info(CS%Ref_val(CS%fldno)%field, size=fld_sz) + call get_external_field_info(CS%Ref_val(CS%fldno)%field, size=fld_sz, axes=CS%Ref_val(CS%fldno)%axes_data) nz_data = fld_sz(3) CS%Ref_val(CS%fldno)%nz_data = nz_data !< individual sponge fields may reside on a different vertical grid CS%Ref_val(CS%fldno)%num_tlevs = fld_sz(4) @@ -868,7 +895,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename CS%Ref_val_u%field = init_external_field(filename_u, fieldname_u) endif fld_sz(1:4) = -1 - call get_external_field_info(CS%Ref_val_u%field, size=fld_sz) + call get_external_field_info(CS%Ref_val_u%field, size=fld_sz, axes=CS%Ref_val_u%axes_data) CS%Ref_val_u%nz_data = fld_sz(3) CS%Ref_val_u%num_tlevs = fld_sz(4) CS%Ref_val_u%scale = US%m_s_to_L_T ; if (present(scale)) CS%Ref_val_u%scale = scale @@ -879,7 +906,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename CS%Ref_val_v%field = init_external_field(filename_v, fieldname_v) endif fld_sz(1:4) = -1 - call get_external_field_info(CS%Ref_val_v%field, size=fld_sz) + call get_external_field_info(CS%Ref_val_v%field, size=fld_sz, axes=CS%Ref_val_v%axes_data) CS%Ref_val_v%nz_data = fld_sz(3) CS%Ref_val_v%num_tlevs = fld_sz(4) CS%Ref_val_v%scale = US%m_s_to_L_T ; if (present(scale)) CS%Ref_val_v%scale = scale @@ -936,7 +963,6 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) ! edges in the input file [Z ~> m] real :: missing_value ! The missing value in the input data field [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: dz_neglect, dz_neglect_edge ! Negligible layer extents [Z ~> m] real :: zTopOfCell, zBottomOfCell ! Interface heights (positive upward) in the input dataset [Z ~> m]. real :: sp_val_u ! Interpolation of sp_val to u-points, often a velocity in [L T-1 ~> m s-1] real :: sp_val_v ! Interpolation of sp_val to v-points, often a velocity in [L T-1 ~> m s-1] @@ -947,23 +973,13 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) Idt = 1.0/dt - if (CS%remap_answer_date >= 20190101) then - dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff - elseif (GV%Boussinesq) then - dz_neglect = US%m_to_Z*1.0e-30 ; dz_neglect_edge = US%m_to_Z*1.0e-10 - elseif (GV%semi_Boussinesq) then - dz_neglect = GV%kg_m2_to_H*GV%H_to_Z*1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z*1.0e-10 - else - dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff - endif - if (CS%time_varying_sponges) then do m=1,CS%fldno nz_data = CS%Ref_val(m)%nz_data call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%field, Time, G, sp_val, & mask_z, z_in, z_edges_in, missing_value, & scale=CS%Ref_val(m)%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & - answer_date=CS%hor_regrid_answer_date) + answer_date=CS%hor_regrid_answer_date, axes=CS%Ref_val(m)%axes_data) allocate( dz_src(nz_data) ) allocate( tmpT1d(nz_data) ) do c=1,CS%num_col @@ -1024,12 +1040,11 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) enddo endif if (CS%time_varying_sponges) then - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val(m)%dz(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) else call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dz%p(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) endif !Backward Euler method if (CS%id_sp_tendency(m) > 0) tmp(i,j,1:nz) = CS%var(m)%p(i,j,1:nz) @@ -1053,7 +1068,7 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) call horiz_interp_and_extrap_tracer(CS%Ref_val_u%field, Time, G, sp_val, & mask_z, z_in, z_edges_in, missing_value, & scale=CS%Ref_val_u%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & - answer_date=CS%hor_regrid_answer_date) + answer_date=CS%hor_regrid_answer_date, axes=CS%Ref_val_u%axes_data) ! Initialize mask_z halos to zero before pass_var, in case of no update mask_z(G%isc-1, G%jsc:G%jec, :) = 0. @@ -1101,7 +1116,7 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) call horiz_interp_and_extrap_tracer(CS%Ref_val_v%field, Time, G, sp_val, & mask_z, z_in, z_edges_in, missing_value, & scale=CS%Ref_val_v%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& - answer_date=CS%hor_regrid_answer_date) + answer_date=CS%hor_regrid_answer_date, axes=CS%Ref_val_v%axes_data) ! Initialize mask_z halos to zero before pass_var, in case of no update mask_z(G%isc:G%iec, G%jsc-1, :) = 0. mask_z(G%isc:G%iec, G%jec+1, :) = 0. @@ -1175,10 +1190,10 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) enddo if (CS%time_varying_sponges) then call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%dz(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) else call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dzu%p(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) endif if (CS%id_sp_u_tendency > 0) tmp_u(i,j,1:nz) = CS%var_u%p(i,j,1:nz) !Backward Euler method @@ -1208,10 +1223,10 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) enddo if (CS%time_varying_sponges) then call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_v%dz(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) else call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dzv%p(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) endif if (CS%id_sp_v_tendency > 0) tmp_v(i,j,1:nz) = CS%var_v%p(i,j,1:nz) !Backward Euler method @@ -1301,11 +1316,13 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, US, turns, param_fi ! Second part: Provide rotated fields for which relaxation is applied - sponge%fldno = sponge_in%fldno - if (fixed_sponge) then allocate(sp_val_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data)) allocate(sp_val(G%isd:G%ied, G%jsd:G%jed, nz_data)) + ! For a fixed sponge, sponge%fldno is incremented from 0 in the calls to set_up_ALE_sponge_field. + sponge%fldno = 0 + else + sponge%fldno = sponge_in%fldno endif do n=1,sponge_in%fldno @@ -1358,8 +1375,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, US, turns, param_fi ! 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.") + call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet implemented.") ! Transfer any existing diag_CS reference pointer sponge%diag => sponge_in%diag diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index a21b992147..5c6bd75da5 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -664,11 +664,11 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & "KPP_calculate: The Waves control structure must be associated if STOKES_MIXING is True.") if (CS%debug) then - call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0, scale=US%Z_to_m*US%s_to_T) - call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0, scale=US%L_to_m**2*US%s_to_T**3) - call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(h, "KPP in: h", G%HI, haloshift=0, unscale=GV%H_to_m) + call hchksum(uStar, "KPP in: uStar", G%HI, haloshift=0, unscale=US%Z_to_m*US%s_to_T) + call hchksum(buoyFlux, "KPP in: buoyFlux", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T**3) + call hchksum(Kt, "KPP in: Kt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP in: Ks", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif nonLocalTrans(:,:) = 0.0 @@ -920,8 +920,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & call cpu_clock_end(id_clock_KPP_calc) if (CS%debug) then - call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif ! send diagnostics to post_data @@ -1022,10 +1022,10 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl "KPP_compute_BLD: The Waves control structure must be associated if STOKES_MIXING is True.") if (CS%debug) then - call hchksum(Salt, "KPP in: S", G%HI, haloshift=0, scale=US%S_to_ppt) - call hchksum(Temp, "KPP in: T", G%HI, haloshift=0, scale=US%C_to_degC) - call hchksum(u, "KPP in: u",G%HI,haloshift=0,scale=US%L_T_to_m_s) - call hchksum(v, "KPP in: v",G%HI,haloshift=0,scale=US%L_T_to_m_s) + call hchksum(Salt, "KPP in: S", G%HI, haloshift=0, unscale=US%S_to_ppt) + call hchksum(Temp, "KPP in: T", G%HI, haloshift=0, unscale=US%C_to_degC) + call hchksum(u, "KPP in: u", G%HI, haloshift=0, unscale=US%L_T_to_m_s) + call hchksum(v, "KPP in: v", G%HI, haloshift=0, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_KPP_compute_BLD) diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 19744cb6c5..ce592a2d9c 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -281,13 +281,13 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) enddo if (CS%debug) then - ! if (CS%id_N2 > 0) call hchksum(N2_3d, "MOM_CVMix_conv: N2",G%HI,haloshift=0) + ! if (CS%id_N2 > 0) call hchksum(N2_3d, "MOM_CVMix_conv: N2", G%HI, haloshift=0, unscale=US%s_to_T**2) ! if (CS%id_kd_conv > 0) & - ! call hchksum(Kd_conv, "MOM_CVMix_conv: Kd_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + ! call hchksum(Kd_conv, "MOM_CVMix_conv: Kd_conv", G%HI, haloshift=0, unscale=US%Z2_T_to_m2_s) ! if (CS%id_kv_conv > 0) & - ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, unscale=US%Z2_T_to_m2_s) + call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif ! send diagnostics to post_data diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 4c0baf3d26..64e7f17ef2 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -234,19 +234,19 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL call get_param(param_file, mdl, "BCKGRND_VDC1", CS%bckgrnd_vdc1, & "Background diffusivity (Ledwell) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.16e-04, scale=GV%m2_s_to_HZ_T) + units="m2 s-1", default=0.16e-04, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_EQ", CS%bckgrnd_vdc_eq, & "Equatorial diffusivity (Gregg) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.01e-04, scale=GV%m2_s_to_HZ_T) + units="m2 s-1", default=0.01e-04, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_PSIM", CS%bckgrnd_vdc_psim, & "Max. PSI induced diffusivity (MacKinnon) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.13e-4, scale=GV%m2_s_to_HZ_T) + units="m2 s-1", default=0.13e-4, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_BAN", CS%bckgrnd_vdc_Banda, & "Banda Sea diffusivity (Gordon) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 1.0e-4, scale=GV%m2_s_to_HZ_T) + units="m2 s-1", default=1.0e-4, scale=GV%m2_s_to_HZ_T) endif call get_param(param_file, mdl, "PRANDTL_BKGND", CS%prandtl_bkgnd, & diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 930e4f9513..0d7472920e 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -4256,8 +4256,8 @@ end function EF4 !! !! This file contains the subroutine (bulkmixedlayer) that !! implements a Kraus-Turner-like bulk mixed layer, based on the work -!! of various people, as described in the review paper by \cite Niiler1977, -!! with particular attention to the form proposed by \cite Oberhuber1993, +!! of various people, as described in the review paper by \cite niiler1977, +!! with particular attention to the form proposed by \cite Oberhuber1993a, !! with an extension to a refined bulk mixed layer as described in !! Hallberg (\cite muller2003). The physical processes portrayed in !! this subroutine include convective adjustment and mixed layer entrainment diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 51e9b33d97..33fe26ff82 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -33,7 +33,6 @@ module MOM_diabatic_aux public diabatic_aux_init, diabatic_aux_end public make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS, triDiagTS_Eulerian public find_uv_at_h, applyBoundaryFluxesInOut, set_pen_shortwave -public diagnoseMLDbyEnergy, diagnoseMLDbyDensityDifference ! 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 @@ -675,389 +674,6 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow end subroutine set_pen_shortwave - -!> Diagnose a mixed layer depth (MLD) determined by a given density difference with the surface. -!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. -subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, & - id_N2subML, id_MLDsq, dz_subML) - type(ocean_grid_type), intent(in) :: G !< Grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer, intent(in) :: id_MLD !< Handle (ID) of MLD diagnostic - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any - !! available thermodynamic fields. - real, intent(in) :: densityDiff !< Density difference to determine MLD [R ~> kg m-3] - type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure - integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification - integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD - real, optional, intent(in) :: dz_subML !< The distance over which to calculate N2subML - !! or 50 m if missing [Z ~> m] - - ! Local variables - real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. - real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m or kg m-2] - real, dimension(SZI_(G)) :: dZ_N2 ! Summed vertical distance used in N2 calculation [Z ~> m] - real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [C ~> degC]. - real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [S ~> ppt]. - real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [R ~> kg m-3]. - real, dimension(SZI_(G),SZK_(GV)) :: dZ_2d ! Layer thicknesses in depth units [Z ~> m] - real, dimension(SZI_(G)) :: dZ, dZm1 ! Layer thicknesses associated with interfaces [Z ~> m] - real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixed layer depth [R ~> kg m-3]. - real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. - real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. - real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. - logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 - ! have been stored already. - real :: gE_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq - ! reference density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. - real :: dZ_sub_ML ! Depth below ML over which to diagnose stratification [Z ~> m] - real :: aFac ! A nondimensional factor [nondim] - real :: ddRho ! A density difference [R ~> kg m-3] - integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ - - id_SQ = -1 ; if (PRESENT(id_MLDsq)) id_SQ = id_MLDsq - - id_N2 = -1 - if (present(id_N2subML)) then - if (present(dz_subML)) then - id_N2 = id_N2subML - dZ_sub_ML = dz_subML - else - call MOM_error(FATAL, "When the diagnostic of the subML stratification is "//& - "requested by providing id_N2_subML to diagnoseMLDbyDensityDifference, "//& - "the distance over which to calculate that distance must also be provided.") - endif - endif - - gE_rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - - pRef_MLD(:) = 0.0 - EOSdom(:) = EOS_domain(G%HI) - do j=js,je - ! Find the vertical distances across layers. - call thickness_to_dz(h, tv, dZ_2d, j, G, GV) - - do i=is,ie ; dZ(i) = 0.5 * dZ_2d(i,1) ; enddo ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) - do i=is,ie - deltaRhoAtK(i) = 0. - MLD(i,j) = 0. - if (id_N2>0) then - subMLN2(i,j) = 0.0 - H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 - T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 - N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. - endif - enddo - do k=2,nz - do i=is,ie - dZm1(i) = dZ(i) ! Depth of center of layer K-1 - dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K - enddo - - ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding - ! the cells that extend over at least dz_subML. - if (id_N2>0) then - do i=is,ie - if (MLD(i,j) == 0.0) then ! Still in the mixed layer. - H_subML(i) = H_subML(i) + h(i,j,k) - elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. - if (dZ_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML - T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) - H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. - dH_N2(i) = 0.5 * h(i,j,k) - dZ_N2(i) = 0.5 * dz_2d(i,k) - elseif (dZ_N2(i) + dZ_2d(i,k) < dZ_sub_ML) then - dH_N2(i) = dH_N2(i) + h(i,j,k) - dZ_N2(i) = dZ_N2(i) + dz_2d(i,k) - else ! This layer includes the base of the region where N2 is calculated. - T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) - dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) - dZ_N2(i) = dZ_N2(i) + 0.5 * dz_2d(i,k) - N2_region_set(i) = .true. - endif - endif - enddo ! i-loop - endif ! id_N2>0 - - ! Mixed-layer depth, using sigma-0 (surface reference pressure) - do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) - do i = is, ie - deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface - ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) - if ((MLD(i,j) == 0.) .and. (ddRho > 0.) .and. & - (deltaRhoAtKm1(i) < densityDiff) .and. (deltaRhoAtK(i) >= densityDiff)) then - aFac = ( densityDiff - deltaRhoAtKm1(i) ) / ddRho - MLD(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) - endif - if (id_SQ > 0) MLD2(i,j) = MLD(i,j)**2 - enddo ! i-loop - enddo ! k-loop - do i=is,ie - if ((MLD(i,j) == 0.) .and. (deltaRhoAtK(i) < densityDiff)) MLD(i,j) = dZ(i) ! Mixing goes to the bottom - enddo - - if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. - do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo - ! if ((.not.N2_region_set(i)) .and. (dZ_N2(i) > 0.5*dZ_sub_ML)) then - ! ! Use whatever stratification we can, measured over whatever distance is available? - ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) - ! N2_region_set(i) = .true. - ! endif - call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, EOSdom) - call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, EOSdom) - do i=is,ie ; if ((G%mask2dT(i,j) > 0.0) .and. N2_region_set(i)) then - subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / dH_N2(i) - endif ; enddo - endif - enddo ! j-loop - - if (id_MLD > 0) call post_data(id_MLD, MLD, diagPtr) - if (id_N2 > 0) call post_data(id_N2, subMLN2, diagPtr) - if (id_SQ > 0) call post_data(id_SQ, MLD2, diagPtr) - -end subroutine diagnoseMLDbyDensityDifference - -!> Diagnose a mixed layer depth (MLD) determined by the depth a given energy value would mix. -!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. -subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) - ! Author: Brandon Reichl - ! Date: October 2, 2020 - ! // - ! *Note that gravity is assumed constant everywhere and divided out of all calculations. - ! - ! This code has been written to step through the columns layer by layer, summing the PE - ! change inferred by mixing the layer with all layers above. When the change exceeds a - ! threshold (determined by input array Mixing_Energy), the code needs to solve for how far - ! into this layer the threshold PE change occurs (assuming constant density layers). - ! This is expressed here via solving the function F(X) = 0 where: - ! F(X) = 0.5 * ( Ca*X^3/(D1+X) + Cb*X^2/(D1+X) + Cc*X/(D1+X) + Dc/(D1+X) - ! + Ca2*X^2 + Cb2*X + Cc2) - ! where all coefficients are determined by the previous mixed layer depth, the - ! density of the previous mixed layer, the present layer thickness, and the present - ! layer density. This equation is worked out by computing the total PE assuming constant - ! density in the mixed layer as well as in the remaining part of the present layer that is - ! not mixed. - ! To solve for X in this equation a Newton's method iteration is employed, which - ! converges extremely quickly (usually 1 guess) since this equation turns out to be rather - ! linear for PE change with increasing X. - ! Input parameters: - integer, dimension(3), intent(in) :: id_MLD !< Energy output diagnostic IDs - type(ocean_grid_type), intent(in) :: G !< Grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 3 MLDs [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any - !! available thermodynamic fields. - type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure - - ! Local variables - real, dimension(SZI_(G),SZJ_(G),3) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. - real, dimension(SZK_(GV)+1) :: Z_int ! Depths of the interfaces from the surface [Z ~> m] - real, dimension(SZI_(G),SZK_(GV)) :: dZ ! Layer thicknesses in depth units [Z ~> m] - real, dimension(SZI_(G),SZK_(GV)) :: Rho_c ! Columns of layer densities [R ~> kg m-3] - real, dimension(SZI_(G)) :: pRef_MLD ! The reference pressure for the mixed layer - ! depth calculation [R L2 T-2 ~> Pa] - real, dimension(3) :: PE_threshold ! The energy threshold divided by g [R Z2 ~> kg m-1] - - real :: PE_Threshold_fraction ! The fractional tolerance of the specified energy - ! for the energy used to mix to the diagnosed depth [nondim] - real :: H_ML ! The accumulated depth of the mixed layer [Z ~> m] - real :: PE ! The cumulative potential energy of the unmixed water column to a depth - ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] - real :: PE_Mixed ! The potential energy of the completely mixed water column to a depth - ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] - real :: RhoDZ_ML ! The depth integrated density of the mixed layer [R Z ~> kg m-2] - real :: H_ML_TST ! A new test value for the depth of the mixed layer [Z ~> m] - real :: PE_Mixed_TST ! The potential energy of the completely mixed water column to a depth - ! of H_ML_TST, divided by the gravitational acceleration [R Z2 ~> kg m-1] - real :: RhoDZ_ML_TST ! A test value of the new depth integrated density of the mixed layer [R Z ~> kg m-2] - real :: Rho_ML ! The average density of the mixed layer [R ~> kg m-3] - - ! These are all temporary variables used to shorten the expressions in the iterations. - real :: R1, R2, Ca, Ca2 ! Some densities [R ~> kg m-3] - real :: D1, D2, X, X2 ! Some thicknesses [Z ~> m] - real :: Cb, Cb2 ! A depth integrated density [R Z ~> kg m-2] - real :: C, D ! A depth squared [Z2 ~> m2] - real :: Cc, Cc2 ! A density times a depth squared [R Z2 ~> kg m-1] - real :: Cd ! A density times a depth cubed [R Z3 ~> kg] - real :: Gx ! A triple integral in depth of density [R Z3 ~> kg] - real :: Gpx ! The derivative of Gx with x [R Z2 ~> kg m-1] - real :: Hx ! The vertical integral depth [Z ~> m] - real :: iHx ! The inverse of Hx [Z-1 ~> m-1] - real :: Hpx ! The derivative of Hx with x, hard coded to 1. Why? [nondim] - real :: Ix ! A double integral in depth of density [R Z2 ~> kg m-1] - real :: Ipx ! The derivative of Ix with x [R Z ~> kg m-2] - real :: Fgx ! The mixing energy difference from the target [R Z2 ~> kg m-1] - real :: Fpx ! The derivative of Fgx with x [R Z ~> kg m-2] - - integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: IT, iM - integer :: i, j, is, ie, js, je, k, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - - pRef_MLD(:) = 0.0 - mld(:,:,:) = 0.0 - PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. - - do iM=1,3 - PE_threshold(iM) = Mixing_Energy(iM) / (US%L_to_Z**2*GV%g_Earth) - enddo - - MLD(:,:,:) = 0.0 - - EOSdom(:) = EOS_domain(G%HI) - - do j=js,je - ! Find the vertical distances across layers. - call thickness_to_dz(h, tv, dz, j, G, GV) - - do k=1,nz - call calculate_density(tv%T(:,j,k), tv%S(:,j,K), pRef_MLD, rho_c(:,k), tv%eqn_of_state, EOSdom) - enddo - - do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then - - Z_int(1) = 0.0 - do k=1,nz - Z_int(K+1) = Z_int(K) - dZ(i,k) - enddo - - do iM=1,3 - - ! Initialize these for each column-wise calculation - PE = 0.0 - RhoDZ_ML = 0.0 - H_ML = 0.0 - RhoDZ_ML_TST = 0.0 - H_ML_TST = 0.0 - PE_Mixed = 0.0 - - do k=1,nz - - ! This is the unmixed PE cumulative sum from top down - PE = PE + 0.5 * Rho_c(i,k) * (Z_int(K)**2 - Z_int(K+1)**2) - - ! This is the depth and integral of density - H_ML_TST = H_ML + dZ(i,k) - RhoDZ_ML_TST = RhoDZ_ML + Rho_c(i,k) * dZ(i,k) - - ! The average density assuming all layers including this were mixed - Rho_ML = RhoDZ_ML_TST/H_ML_TST - - ! The PE assuming all layers including this were mixed - ! Note that 0. could be replaced with "Surface", which doesn't have to be 0 - ! but 0 is a good reference value. - PE_Mixed_TST = 0.5 * Rho_ML * (0.**2 - (0. - H_ML_TST)**2) - - ! Check if we supplied enough energy to mix to this layer - if (PE_Mixed_TST - PE <= PE_threshold(iM)) then - H_ML = H_ML_TST - RhoDZ_ML = RhoDZ_ML_TST - - else ! If not, we need to solve where the energy ran out - ! This will be done with a Newton's method iteration: - - R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) - D1 = H_ML ! The thickness of the mixed layer (not including this layer) - R2 = Rho_c(i,k) ! The density of this layer - D2 = dZ(i,k) ! The thickness of this layer - - ! This block could be used to calculate the function coefficients if - ! we don't reference all values to a surface designated as z=0 - ! S = Surface - ! Ca = -(R2) - ! Cb = -( (R1*D1) + R2*(2.*D1-2.*S) ) - ! D = D1**2. - 2.*D1*S - ! Cc = -( R1*D1*(2.*D1-2.*S) + R2*D ) - ! Cd = -(R1*D1*D) - ! Ca2 = R2 - ! Cb2 = R2*(2*D1-2*S) - ! C = S**2 + D2**2 + D1**2 - 2*D1*S - 2.*D2*S +2.*D1*D2 - ! Cc2 = R2*(D+S**2-C) - ! - ! If the surface is S = 0, it simplifies to: - Ca = -R2 - Cb = -(R1 * D1 + R2 * (2. * D1)) - D = D1**2 - Cc = -(R1 * D1 * (2. * D1) + (R2 * D)) - Cd = -R1 * (D1 * D) - Ca2 = R2 - Cb2 = R2 * (2. * D1) - C = D2**2 + D1**2 + 2. * (D1 * D2) - Cc2 = R2 * (D - C) - - ! First guess for an iteration using Newton's method - X = dZ(i,k) * 0.5 - - IT=0 - do while(IT<10)!We can iterate up to 10 times - ! We are trying to solve the function: - ! F(x) = G(x)/H(x)+I(x) - ! for where F(x) = PE+PE_threshold, or equivalently for where - ! F(x) = G(x)/H(x)+I(x) - (PE+PE_threshold) = 0 - ! We also need the derivative of this function for the Newton's method iteration - ! F'(x) = (G'(x)H(x)-G(x)H'(x))/H(x)^2 + I'(x) - ! G and its derivative - Gx = 0.5 * (Ca * (X*X*X) + Cb * X**2 + Cc * X + Cd) - Gpx = 0.5 * (3. * (Ca * X**2) + 2. * (Cb * X) + Cc) - ! H, its inverse, and its derivative - Hx = D1 + X - iHx = 1. / Hx - Hpx = 1. - ! I and its derivative - Ix = 0.5 * (Ca2 * X**2 + Cb2 * X + Cc2) - Ipx = 0.5 * (2. * Ca2 * X + Cb2) - - ! The Function and its derivative: - PE_Mixed = Gx * iHx + Ix - Fgx = PE_Mixed - (PE + PE_threshold(iM)) - Fpx = (Gpx * Hx - Hpx * Gx) * iHx**2 + Ipx - - ! Check if our solution is within the threshold bounds, if not update - ! using Newton's method. This appears to converge almost always in - ! one step because the function is very close to linear in most applications. - if (abs(Fgx) > PE_Threshold(iM) * PE_Threshold_fraction) then - X2 = X - Fgx / Fpx - IT = IT + 1 - if (X2 < 0. .or. X2 > dZ(i,k)) then - ! The iteration seems to be robust, but we need to do something *if* - ! things go wrong... How should we treat failed iteration? - ! Present solution: Stop trying to compute and just say we can't mix this layer. - X=0 - exit - else - X = X2 - endif - else - exit! Quit the iteration - endif - enddo - H_ML = H_ML + X - exit! Quit looping through the column - endif - enddo - MLD(i,j,iM) = H_ML - enddo - endif ; enddo - enddo - - if (id_MLD(1) > 0) call post_data(id_MLD(1), MLD(:,:,1), diagPtr) - if (id_MLD(2) > 0) call post_data(id_MLD(2), MLD(:,:,2), diagPtr) - if (id_MLD(3) > 0) call post_data(id_MLD(3), MLD(:,:,3), diagPtr) - -end subroutine diagnoseMLDbyEnergy - !> Update the thickness, temperature, and salinity due to thermodynamic !! boundary forcing (contained in fluxes type) applied to h, tv%T and tv%S, !! and calculate the TKE implications of this heating. @@ -1953,16 +1569,8 @@ end subroutine diabatic_aux_end !! The subroutine set_pen_shortwave determines the optical properties of the water column and !! the net shortwave fluxes, and stores them in the optics type, working via calls to set_opacity. !! -!! The subroutine diagnoseMLDbyDensityDifference diagnoses a mixed layer depth based on a -!! density difference criterion, and may also estimate the stratification of the water below -!! this diagnosed mixed layer. -!! -!! The subroutine diagnoseMLDbyEnergy diagnoses a mixed layer depth based on a mixing-energy -!! criterion, as described by Reichl et al., 2022, JGR: Oceans, doi:10.1029/2021JC018140. -!! !! The subroutine applyBoundaryFluxesInOut updates the layer thicknesses, temperatures and !! salinities due to the application of the surface forcing. It may also calculate the implied !! turbulent kinetic energy requirements for this forcing to be mixed over the model's finite !! vertical resolution in the surface layers. - end module MOM_diabatic_aux diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index d7cb102e05..c5297a3cf0 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -14,7 +14,6 @@ module MOM_diabatic_driver use MOM_diabatic_aux, only : make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS use MOM_diabatic_aux, only : triDiagTS_Eulerian, find_uv_at_h use MOM_diabatic_aux, only : applyBoundaryFluxesInOut, set_pen_shortwave -use MOM_diabatic_aux, only : diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : post_product_sum_u, post_product_sum_v use MOM_diag_mediator, only : diag_ctrl, time_type, diag_update_remap_grids @@ -22,6 +21,7 @@ module MOM_diabatic_driver use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init, diag_grid_storage_end use MOM_diag_mediator, only : diag_copy_diag_to_storage, diag_copy_storage_to_diag use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids +use MOM_diagnose_mld, only : diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy use MOM_diapyc_energy_req, only : diapyc_energy_req_init, diapyc_energy_req_end use MOM_diapyc_energy_req, only : diapyc_energy_req_calc, diapyc_energy_req_test, diapyc_energy_req_CS use MOM_CVMix_conv, only : CVMix_conv_init, CVMix_conv_cs @@ -175,6 +175,8 @@ module MOM_diabatic_driver real :: dz_subML_N2 !< The distance over which to calculate a diagnostic of the !! average stratification at the base of the mixed layer [Z ~> m]. real :: MLD_En_vals(3) !< Energy values for energy mixed layer diagnostics [R Z3 T-2 ~> J m-2] + real :: ref_h_mld = 0.0 !< The depth of the "surface" density used in a difference mixed based + !! MLD calculation [Z ~> m]. !>@{ Diagnostic IDs integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic @@ -183,6 +185,7 @@ module MOM_diabatic_driver integer :: id_Tdif = -1, id_Sdif = -1, id_Tadv = -1, id_Sadv = -1 ! These are handles to diagnostics related to the mixed layer properties. integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 + integer :: id_MLD_003_zr = -1, id_MLD_003_rr = -1 integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 ! These are handles to diagnostics that are only available in non-ALE layered mode. @@ -479,13 +482,16 @@ subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & call enable_averages(dt, Time_end, CS%diag) if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03*US%kg_m3_to_R, G, GV, US, CS%diag, & + CS%ref_h_mld, CS%id_MLD_003_zr, CS%id_MLD_003_rr, & id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) endif if (CS%id_MLD_0125 > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125*US%kg_m3_to_R, G, GV, US, CS%diag) + call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125*US%kg_m3_to_R, G, GV, US, CS%diag, & + ref_H_MLD=0.0, id_ref_z=-1, id_ref_rho=-1) endif if (CS%id_MLD_user > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag) + call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag, & + ref_H_MLD=0.0, id_ref_z=-1, id_ref_rho=-1) endif if ((CS%id_MLD_EN1 > 0) .or. (CS%id_MLD_EN2 > 0) .or. (CS%id_MLD_EN3 > 0)) then call diagnoseMLDbyEnergy((/CS%id_MLD_EN1, CS%id_MLD_EN2, CS%id_MLD_EN3/),& @@ -648,7 +654,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif ! Set diffusivities for heat and salt separately @@ -669,8 +675,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%debug) then - call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif call cpu_clock_begin(id_clock_kpp) @@ -735,12 +741,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & - scale=US%C_to_degC*GV%H_to_m*US%s_to_T) + unscale=US%C_to_degC*GV%H_to_m*US%s_to_T) call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & - scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + unscale=US%S_to_ppt*GV%H_to_m*US%s_to_T) call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif @@ -810,7 +816,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after calc_entrain ", tv, G, US) call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ent_s, "after calc_entrain ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_s, "after calc_entrain ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif ! Save fields before boundary forcing is applied for tendency diagnostics @@ -836,19 +842,19 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML) if (CS%debug) then - call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_mks) - call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_mks) + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, unscale=GV%H_to_mks) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, unscale=GV%H_to_mks) call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & - scale=US%RZ3_T3_to_W_m2*US%T_to_s) + unscale=US%RZ3_T3_to_W_m2*US%T_to_s) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & - scale=US%kg_m3_to_R*US%degC_to_C) + unscale=US%kg_m3_to_R*US%degC_to_C) call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, & - scale=US%kg_m3_to_R*US%ppt_to_S) - call hchksum(h, "after applyBoundaryFluxes h", G%HI, haloshift=0, scale=GV%H_to_mks) - call hchksum(tv%T, "after applyBoundaryFluxes tv%T", G%HI, haloshift=0, scale=US%C_to_degC) - call hchksum(tv%S, "after applyBoundaryFluxes tv%S", G%HI, haloshift=0, scale=US%S_to_ppt) + unscale=US%kg_m3_to_R*US%ppt_to_S) + call hchksum(h, "after applyBoundaryFluxes h", G%HI, haloshift=0, unscale=GV%H_to_mks) + call hchksum(tv%T, "after applyBoundaryFluxes tv%T", G%HI, haloshift=0, unscale=US%C_to_degC) + call hchksum(tv%S, "after applyBoundaryFluxes tv%S", G%HI, haloshift=0, unscale=US%S_to_ppt) call hchksum(SkinBuoyFlux, "after applyBdryFlux SkinBuoyFlux", G%HI, haloshift=0, & - scale=US%Z_to_m**2*US%s_to_T**3) + unscale=US%Z_to_m**2*US%s_to_T**3) endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -885,9 +891,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif else @@ -930,8 +936,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim if (associated(tv%T)) then if (CS%debug) then - call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -1263,12 +1269,9 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif - ! Store the diagnosed typical diffusivity at interfaces. - if (CS%id_Kd_int > 0) call post_data(CS%id_Kd_int, Kd_heat, CS%diag) - ! Set diffusivities for heat and salt separately, and possibly change the meaning of Kd_heat. if (CS%double_diffuse) then ! Add contributions from double diffusion @@ -1285,8 +1288,8 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, endif if (CS%debug) then - call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif if (CS%useKPP) then @@ -1341,12 +1344,12 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & - scale=US%C_to_degC*GV%H_to_m*US%s_to_T) + unscale=US%C_to_degC*GV%H_to_m*US%s_to_T) call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & - scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + unscale=US%S_to_ppt*GV%H_to_m*US%s_to_T) call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif @@ -1396,14 +1399,14 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML) if (CS%debug) then - call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & - scale=US%RZ3_T3_to_W_m2*US%T_to_s) + unscale=US%RZ3_T3_to_W_m2*US%T_to_s) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & - scale=US%kg_m3_to_R*US%degC_to_C) + unscale=US%kg_m3_to_R*US%degC_to_C) call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, & - scale=US%kg_m3_to_R*US%ppt_to_S) + unscale=US%kg_m3_to_R*US%ppt_to_S) endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -1431,9 +1434,9 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif else @@ -1468,8 +1471,8 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, if (associated(tv%T)) then if (CS%debug) then - call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -1536,6 +1539,14 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + if (CS%id_Kd_int > 0) then + if (CS%double_diffuse .or. CS%useKPP) then + do K=1,nz ; do j=js,je ; do i=is,ie + Kd_heat(i,j,k) = min(Kd_heat(i,j,k), Kd_salt(i,j,k)) + enddo ; enddo ; enddo + endif + call post_data(CS%id_Kd_int, Kd_heat, CS%diag) + endif if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) @@ -1855,8 +1866,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then call find_uv_at_h(u, v, h_orig, u_h, v_h, G, GV, US, eaml, ebml) if (CS%debug) then - call hchksum(eaml, "after find_uv_at_h eaml", G%HI, scale=GV%H_to_MKS) - call hchksum(ebml, "after find_uv_at_h ebml", G%HI, scale=GV%H_to_MKS) + call hchksum(eaml, "after find_uv_at_h eaml", G%HI, unscale=GV%H_to_MKS) + call hchksum(ebml, "after find_uv_at_h ebml", G%HI, unscale=GV%H_to_MKS) endif else call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -1894,8 +1905,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif @@ -1979,8 +1990,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif endif ! endif for KPP @@ -1993,9 +2004,9 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e call cpu_clock_begin(id_clock_kpp) if (CS%debug) then call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & - scale=US%C_to_degC*GV%H_to_m*US%s_to_T) + unscale=US%C_to_degC*GV%H_to_m*US%s_to_T) call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & - scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + unscale=US%S_to_ppt*GV%H_to_m*US%s_to_T) call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif @@ -2052,8 +2063,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after calc_entrain ", tv, G, US) call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif ! Save fields before boundary forcing is applied for tendency diagnostics @@ -2208,8 +2219,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e eb(i,j,k) = eb(i,j,k) + ebml(i,j,k) enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ea, "after ea = ea + eaml", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(eb, "after eb = eb + ebml", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ea, "after ea = ea + eaml", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eb, "after eb = eb + ebml", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif endif @@ -2254,8 +2265,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e if (associated(tv%T)) then if (CS%debug) then - call hchksum(ea, "before triDiagTS ea ", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(eb, "before triDiagTS eb ", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ea, "before triDiagTS ea ", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eb, "before triDiagTS eb ", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -2302,8 +2313,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e if (CS%debug) then call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, US, haloshift=0) call MOM_thermovar_chksum("after mixed layer ", tv, G, US) - call hchksum(ea, "after mixed layer ea", G%HI, scale=GV%H_to_MKS) - call hchksum(eb, "after mixed layer eb", G%HI, scale=GV%H_to_MKS) + call hchksum(ea, "after mixed layer ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "after mixed layer eb", G%HI, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_remap) @@ -2493,8 +2504,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e ! mixed layer turbulence is applied elsewhere. if (CS%use_bulkmixedlayer) then if (CS%debug) then - call hchksum(ea, "before net flux rearrangement ea", G%HI, scale=GV%H_to_MKS) - call hchksum(eb, "before net flux rearrangement eb", G%HI, scale=GV%H_to_MKS) + call hchksum(ea, "before net flux rearrangement ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "before net flux rearrangement eb", G%HI, unscale=GV%H_to_MKS) endif !$OMP parallel do default(shared) private(net_ent) do j=js,je @@ -2505,8 +2516,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e enddo ; enddo enddo if (CS%debug) then - call hchksum(ea, "after net flux rearrangement ea", G%HI, scale=GV%H_to_MKS) - call hchksum(eb, "after net flux rearrangement eb", G%HI, scale=GV%H_to_MKS) + call hchksum(ea, "after net flux rearrangement ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "after net flux rearrangement eb", G%HI, unscale=GV%H_to_MKS) endif endif @@ -2537,9 +2548,9 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e ! or enters the ocean with the surface velocity. if (CS%debug) then call MOM_state_chksum("before u/v tridiag ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ea, "before u/v tridiag ea", G%HI, scale=GV%H_to_MKS) - call hchksum(eb, "before u/v tridiag eb", G%HI, scale=GV%H_to_MKS) - call hchksum(hold, "before u/v tridiag hold", G%HI, scale=GV%H_to_MKS) + call hchksum(ea, "before u/v tridiag ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "before u/v tridiag eb", G%HI, unscale=GV%H_to_MKS) + call hchksum(hold, "before u/v tridiag hold", G%HI, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -3268,6 +3279,15 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Squared buoyancy frequency below mixed layer', units='s-2', conversion=US%s_to_T**2) CS%id_MLD_user = register_diag_field('ocean_model', 'MLD_user', diag%axesT1, Time, & 'Mixed layer depth (used defined)', units='m', conversion=US%Z_to_m) + if (CS%id_MLD_003 > 0) then + call get_param(param_file, mdl, "HREF_FOR_MLD", CS%ref_h_mld, & + "Reference depth used to calculate the potential density used to find the mixed layer depth "//& + "based on a delta rho = 0.03 kg/m3.", units='m', default=0.0, scale=US%m_to_Z) + CS%id_MLD_003_zr = register_diag_field('ocean_model', 'MLD_003_refZ', diag%axesT1, Time, & + 'Depth of reference density for MLD (delta rho = 0.03)', units='m', conversion=US%Z_to_m) + CS%id_MLD_003_rr = register_diag_field('ocean_model', 'MLD_003_refRho', diag%axesT1, Time, & + 'Reference density for MLD (delta rho = 0.03)', units='kg/m3', conversion=US%R_to_kg_m3) + endif endif call get_param(param_file, mdl, "DIAG_MLD_DENSITY_DIFF", CS%MLDdensityDifference, & "The density difference used to determine a diagnostic mixed "//& @@ -3300,8 +3320,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_Kd_int = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_energetic_PBL) then - CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & - 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & + 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif CS%id_Kd_heat = register_diag_field('ocean_model', 'Kd_heat', diag%axesTi, Time, & @@ -3568,8 +3588,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di end subroutine diabatic_driver_init !> Routine to register restarts, pass-through to children modules -subroutine register_diabatic_restarts(G, US, param_file, int_tide_CSp, restart_CSp) +subroutine register_diabatic_restarts(G, GV, US, param_file, int_tide_CSp, restart_CSp) 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure @@ -3582,7 +3603,7 @@ subroutine register_diabatic_restarts(G, US, param_file, int_tide_CSp, restart_C call read_param(param_file, "INTERNAL_TIDES", use_int_tides) if (use_int_tides) then - call register_int_tide_restarts(G, US, param_file, int_tide_CSp, restart_CSp) + call register_int_tide_restarts(G, GV, US, param_file, int_tide_CSp, restart_CSp) endif end subroutine register_diabatic_restarts diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 7280106125..47550fa93d 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -42,8 +42,8 @@ module MOM_int_tide_input logical :: debug !< If true, write verbose checksums for debugging. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. - real :: TKE_itide_max !< Maximum Internal tide conversion - !! available to mix above the BBL [R Z3 T-3 ~> W m-2] + real :: TKE_itide_maxi !< Maximum Internal tide conversion + !! available to mix above the BBL [H Z2 T-3 ~> m3 s-3 or W m-2] real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -51,7 +51,7 @@ module MOM_int_tide_input !< The time-invariant field that enters the TKE_itidal input calculation noting that the !! stratification and perhaps density are time-varying [R Z4 H-1 T-2 ~> J m-2 or J m kg-1]. real, allocatable, dimension(:,:,:) :: & - TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [H Z2 T-3 ~> m3 s-3 or W m-2]. tideamp !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. character(len=200) :: inputdir !< The directory for input files. @@ -105,7 +105,9 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) real, dimension(SZI_(G),SZJ_(G)) :: & N2_bot ! The bottom squared buoyancy frequency [T-2 ~> s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - Rho_bot ! The average near-bottom density or the Boussinesq reference density [R ~> kg m-3]. + Rho_bot, & ! The average near-bottom density or the Boussinesq reference density [R ~> kg m-3]. + h_bot ! Bottom boundary layer thickness [H ~> m or kg m-2]. + integer, dimension(SZI_(G),SZJ_(G)) :: k_bot ! Bottom boundary layer top layer index. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & T_f, S_f ! The temperature and salinity in [C ~> degC] and [S ~> ppt] with the values in @@ -114,11 +116,16 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! equation of state. logical :: avg_enabled ! for testing internal tides (BDM) type(time_type) :: time_end !< For use in testing internal tides (BDM) + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] integer :: i, j, is, ie, js, je, nz, isd, ied, jsd, jed integer :: i_global, j_global integer :: fr + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -135,7 +142,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, US, larger_h_denom=.true.) endif - call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot, Rho_bot) + call find_N2_bottom(G, GV, US, tv, fluxes, h, T_f, S_f, itide%h2, N2_bot, Rho_bot, h_bot, k_bot) avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) @@ -143,15 +150,16 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) !$OMP parallel do default(shared) do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) - CS%TKE_itidal_input(i,j,fr) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), CS%TKE_itide_max) + CS%TKE_itidal_input(i,j,fr) = min(GV%RZ_to_H*GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & + CS%TKE_itide_maxi) enddo ; enddo ; enddo else !$OMP parallel do default(shared) do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) itide%Rho_bot(i,j) = G%mask2dT(i,j) * Rho_bot(i,j) - CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & - CS%TKE_itide_max) + CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*GV%RZ_to_H*Rho_bot(i,j))*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & + CS%TKE_itide_maxi) enddo ; enddo ; enddo endif @@ -163,7 +171,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) i_global = i + G%idg_offset j_global = j + G%jdg_offset if ((i_global == CS%int_tide_source_i) .and. (j_global == CS%int_tide_source_j)) then - CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*W_m2_to_HZ2_T3 endif enddo ; enddo ; enddo else @@ -171,7 +179,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! Input an arbitrary energy point source.id_ if (((G%geoLonCu(I-1,j)-CS%int_tide_source_x) * (G%geoLonBu(I,j)-CS%int_tide_source_x) <= 0.0) .and. & ((G%geoLatCv(i,J-1)-CS%int_tide_source_y) * (G%geoLatCv(i,j)-CS%int_tide_source_y) <= 0.0)) then - CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*W_m2_to_HZ2_T3 endif enddo ; enddo ; enddo endif @@ -179,9 +187,9 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) endif if (CS%debug) then - call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) - call hchksum(CS%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & - scale=US%RZ3_T3_to_W_m2) + call hchksum(N2_bot, "N2_bot", G%HI, haloshift=0, unscale=US%s_to_T**2) + call hchksum(CS%TKE_itidal_input,"TKE_itidal_input", G%HI, haloshift=0, & + unscale=HZ2_T3_to_W_m2) endif call enable_averages(dt, time_end, CS%diag) @@ -198,23 +206,26 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) end subroutine set_int_tide_input !> Estimates the near-bottom buoyancy frequency (N^2). -subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bot) +subroutine find_N2_bottom(G, GV, US, tv, fluxes, h, T_f, S_f, h2, N2_bot, Rho_bot, h_bot, k_bot) 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 thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the !! thermodynamic fields + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_f !< Temperature after vertical filtering to !! smooth out the values in thin layers [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_f !< Salinity after vertical filtering to !! smooth out the values in thin layers [S ~> ppt]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h2 !< Bottom topographic roughness [Z2 ~> m2]. - type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy frequency at the !! ocean bottom [T-2 ~> s-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: rho_bot !< The average density near the ocean + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Rho_bot !< The average density near the ocean !! bottom [R ~> kg m-3] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G),SZJ_(G)), intent(out) :: k_bot !< Bottom boundary layer top layer index + ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. @@ -247,7 +258,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bo enddo !$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & - !$OMP h2,N2_bot,rho_bot,G_Rho0,EOSdom) & + !$OMP h2,N2_bot,Rho_bot,h_bot,k_bot,G_Rho0,EOSdom) & !$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & !$OMP dz,hb,dRho_bot,z_from_bot,do_i,h_amp,do_any,dz_int) & !$OMP firstprivate(dRho_int) @@ -324,7 +335,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bo enddo else ! Average the density over the envelope of the topography. - call find_rho_bottom(h, dz, pres, h_amp, tv, j, G, GV, US, Rho_bot(:,j)) + call find_rho_bottom(G, GV, US, tv, h, dz, pres, h_amp, j, Rho_bot(:,j), h_bot(:,j), k_bot(:,j)) endif enddo @@ -333,9 +344,10 @@ end subroutine find_N2_bottom !> Returns TKE_itidal_input subroutine get_input_TKE(G, TKE_itidal_input, nFreq, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). - real, dimension(SZI_(G),SZJ_(G),nFreq), & - intent(out) :: TKE_itidal_input !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. integer, intent(in) :: nFreq !< number of frequencies + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: TKE_itidal_input !< The energy input to the internal waves + !! [H Z2 T-3 ~> m3 s-3 or W m-2]. type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control !! structure for the internal tide input module. integer :: i,j,fr @@ -349,9 +361,9 @@ end subroutine get_input_TKE !> Returns barotropic tidal velocities subroutine get_barotropic_tidal_vel(G, vel_btTide, nFreq, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + integer, intent(in) :: nFreq !< number of frequencies real, dimension(SZI_(G),SZJ_(G),nFreq), & intent(out) :: vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. - integer, intent(in) :: nFreq !< number of frequencies type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control !! structure for the internal tide input module. integer :: i,j,fr @@ -392,6 +404,8 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) real :: kappa_h2_factor ! factor for the product of wavenumber * rms sgs height [nondim]. real :: kappa_itides ! topographic wavenumber and non-dimensional scaling [L-1 ~> m-1] real :: min_zbot_itides ! Minimum ocean depth for internal tide conversion [Z ~> m]. + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] integer :: tlen_days !< Time interval from start for adding wave source !! for testing internal tides (BDM) integer :: i, j, is, ie, js, je, isd, ied, jsd, jed @@ -417,6 +431,9 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) CS%diag => diag + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -455,10 +472,10 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & "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, & + call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_maxi, & "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3, scale=US%W_m2_to_RZ3_T3) + units="W m-2", default=1.0e3, scale=W_m2_to_HZ2_T3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & "If true, read a file (given by TIDEAMP_FILE) containing "//& @@ -551,7 +568,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) write(var_descript, '("Internal Tide Driven Turbulent Kinetic Energy in frequency ",i1)') fr CS%id_TKE_itidal_itide(fr) = register_diag_field('ocean_model',var_name,diag%axesT1,Time, & - var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) enddo CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 536d25e595..f2c47ab214 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -54,6 +54,10 @@ module MOM_kappa_shear real :: lambda2_N_S !< The square of the ratio of the coefficients of !! the buoyancy and shear scales in the diffusivity !! equation, 0 to eliminate the shear scale [nondim]. + real :: lz_rescale !< A coefficient to rescale the distance to the nearest + !! solid boundary. This adjustment is to account for + !! regions where 3 dimensional turbulence prevents the + !! growth of shear instabilies [nondim]. real :: TKE_bg !< The background level of TKE [Z2 T-2 ~> m2 s-2]. real :: kappa_0 !< The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] real :: kappa_seed !< A moderately large seed value of diapycnal diffusivity that @@ -333,8 +337,8 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & enddo ! end of j-loop if (CS%debug) then - call hchksum(kappa_io, "kappa", G%HI, scale=GV%HZ_T_to_m2_s) - call hchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(kappa_io, "kappa", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(tke_io, "tke", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) @@ -617,8 +621,8 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ enddo ! end of J-loop if (CS%debug) then - call hchksum(kappa_io, "kappa", G%HI, scale=GV%HZ_T_to_m2_s) - call Bchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(kappa_io, "kappa", G%HI, unscale=GV%HZ_T_to_m2_s) + call Bchksum(tke_io, "tke", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) @@ -746,6 +750,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la real :: wt_b ! The fraction of a layer thickness identified with the interface ! below a layer [nondim] real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1]. + real :: I_lz_rescale_sqr ! The inverse of a rescaling factor for L2_bdry (Lz) squared [nondim]. logical :: valid_dt ! If true, all levels so far exhibit acceptably small changes in k_src. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. @@ -764,6 +769,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la g_R0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 k0dt = dt*CS%kappa_0 + I_lz_rescale_sqr = 1.0; if (CS%lz_rescale > 0) I_lz_rescale_sqr = 1/(CS%lz_rescale*CS%lz_rescale) + tol_dksrc = CS%kappa_src_max_chg if (tol_dksrc == 10.0) then ! This is equivalent to the expression below, but avoids changes at roundoff for the default value. @@ -794,8 +801,11 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la do K=nzc,2,-1 dist_from_bot = dist_from_bot + dz_lay(k) h_from_bot = h_from_bot + hlay(k) + ! Find the inverse of the squared distances from the boundaries, I_L2_bdry(K) = ((dist_from_top(K) + dist_from_bot) * (h_from_top(K) + h_from_bot)) / & ((dist_from_top(K) * dist_from_bot) * (h_from_top(K) * h_from_bot)) + ! reduce the distance by a factor of "lz_rescale" + I_L2_bdry(K) = I_lz_rescale_sqr*I_L2_bdry(K) enddo ! Determine the velocities and thicknesses after eliminating massless @@ -1918,6 +1928,11 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "Set this to 0 (the default) to eliminate the shear scale. "//& "This is only used if USE_JACKSON_PARAM is true.", & units="nondim", default=0.0, do_not_log=just_read) + call get_param(param_file, mdl, "LZ_RESCALE", CS%lz_rescale, & + "A coefficient to rescale the distance to the nearest solid boundary. "//& + "This adjustment is to account for regions where 3 dimensional turbulence "//& + "prevents the growth of shear instabilies [nondim].", & + units="nondim", default=1.0) call get_param(param_file, mdl, "KAPPA_SHEAR_TOL_ERR", CS%kappa_tol_err, & "The fractional error in kappa that is tolerated. "//& "Iteration stops when changes between subsequent "//& diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 658bdca31d..fc6d8380c5 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -23,7 +23,7 @@ module MOM_set_diffusivity use MOM_full_convection, only : full_convection use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom -use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss +use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss, get_lowmode_diffusivity use MOM_intrinsic_functions, only : invcosh use MOM_io, only : slasher, MOM_read_data use MOM_isopycnal_slopes, only : vert_fill_TS @@ -148,6 +148,7 @@ module MOM_set_diffusivity logical :: double_diffusion !< If true, enable double-diffusive mixing using an old method. logical :: use_CVMix_ddiff !< If true, enable double-diffusive mixing via CVMix. logical :: use_tidal_mixing !< If true, activate tidal mixing diffusivity. + logical :: use_int_tides !< If true, use internal tides ray tracing logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that !! does not rely on a layer-formulation. real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering [nondim] @@ -157,7 +158,12 @@ module MOM_set_diffusivity integer :: answer_date !< The vintage of the order of arithmetic and expressions in this module's !! calculations. Values below 20190101 recover the answers from the !! end of 2018, while higher values use updated and more robust forms - !! of the same expressions. + !! of the same expressions. Values above 20240630 use more accurate + !! expressions for cases where USE_LOTW_BBL_DIFFUSIVITY is true. + integer :: LOTW_BBL_answer_date !< The vintage of the order of arithmetic and expressions + !! in the LOTW_BBL calculations. Values below 20240630 recover the + !! original answers, while higher values use more accurate expressions. + !! This only applies when USE_LOTW_BBL_DIFFUSIVITY is true. character(len=200) :: inputdir !< The directory in which input files are found type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() !< Control structure for a child module @@ -171,8 +177,11 @@ module MOM_set_diffusivity !>@{ Diagnostic IDs integer :: id_maxTKE = -1, id_TKE_to_Kd = -1, id_Kd_user = -1 integer :: id_Kd_layer = -1, id_Kd_BBL = -1, id_N2 = -1 - integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 - integer :: id_Kd_bkgnd = -1, id_Kv_bkgnd = -1 + integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 + integer :: id_Kd_bkgnd = -1, id_Kv_bkgnd = -1, id_Kd_leak = -1 + integer :: id_Kd_quad = -1, id_Kd_itidal = -1, id_Kd_Froude = -1, id_Kd_slope = -1 + integer :: id_prof_leak = -1, id_prof_quad = -1, id_prof_itidal= -1 + integer :: id_prof_Froude= -1, id_prof_slope = -1, id_bbl_thick = -1, id_kbbl = -1 !>@} end type set_diffusivity_CS @@ -180,16 +189,29 @@ module MOM_set_diffusivity !> This structure has memory for used in calculating diagnostics of diffusivity type diffusivity_diags real, pointer, dimension(:,:,:) :: & - N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] - Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] - maxTKE => NULL(), & !< energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] - Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] - KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - drho_rat => NULL() !< The density difference ratio used in double diffusion [nondim]. + N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] + Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] + maxTKE => NULL(), & !< energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] + Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] + KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + drho_rat => NULL(), & !< The density difference ratio used in double diffusion [nondim]. + Kd_leak => NULL(), & !< internal tides leakage diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_quad => NULL(), & !< internal tides bottom drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_itidal => NULL(), & !< internal tides wave drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Froude => NULL(), & !< internal tides high Froude diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_slope => NULL(), & !< internal tides critical slopes diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + prof_leak => NULL(), & !< vertical profile for leakage [H-1 ~> m-1 or m2 kg-1] + prof_quad => NULL(), & !< vertical profile for bottom drag [H-1 ~> m-1 or m2 kg-1] + prof_itidal => NULL(), & !< vertical profile for wave drag [H-1 ~> m-1 or m2 kg-1] + prof_Froude => NULL(), & !< vertical profile for Froude drag [H-1 ~> m-1 or m2 kg-1] + prof_slope => NULL() !< vertical profile for critical slopes [H-1 ~> m-1 or m2 kg-1] + real, pointer, dimension(:,:) :: bbl_thick => NULL(), & !< bottom boundary layer thickness [H ~> m or kg m-2] + kbbl => NULL() !< top of bottom boundary layer + real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL() !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE !! dissipated within a layer and Kd in that layer @@ -247,6 +269,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! local variables real :: N2_bot(SZI_(G)) ! Bottom squared buoyancy frequency [T-2 ~> s-2] real :: rho_bot(SZI_(G)) ! In situ near-bottom density [T-2 ~> s-2] + real :: h_bot(SZI_(G)) ! Bottom boundary layer thickness [H ~> m or kg m-2] + integer :: k_bot(SZI_(G)) ! Bottom boundary layer thickness top layer index type(diffusivity_diags) :: dd ! structure with arrays of available diags @@ -259,6 +283,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] dz, & !< Height change across layers [Z ~> m] maxTKE, & !< Energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] + prof_leak_2d, & !< vertical profile for leakage [Z-1 ~> m-1] + prof_quad_2d, & !< vertical profile for bottom drag [Z-1 ~> m-1] + prof_itidal_2d, & !< vertical profile for wave drag [Z-1 ~> m-1] + prof_Froude_2d, & !< vertical profile for Froude drag [Z-1 ~> m-1] + prof_slope_2d, & !< vertical profile for critical slopes [Z-1 ~> m-1] TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer !< [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] @@ -267,6 +296,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2] Kd_int_2d, & !< The interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kv_bkgnd, & !< The background diffusion related interface viscosities [H Z T-1 ~> m2 s-1 or Pa s] + Kd_leak_2d, & !< internal tides leakage diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_quad_2d, & !< internal tides bottom drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_itidal_2d, & !< internal tides wave drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Froude_2d, & !< internal tides high Froude diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_slope_2d, & !< internal tides critical slopes diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] dRho_int, & !< Locally referenced potential density difference across interfaces [R ~> kg m-3] KT_extra, & !< Double diffusion diffusivity of temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] KS_extra !< Double diffusion diffusivity of salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -311,6 +345,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i "when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & + CS%use_int_tides .or. & (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) ! Set Kd_lay, Kd_int and Kv_slow to constant values, mostly to fill the halos. @@ -337,13 +372,27 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%id_Kd_bkgnd > 0) allocate(dd%Kd_bkgnd(isd:ied,jsd:jed,nz+1), source=0.) if (CS%id_Kv_bkgnd > 0) allocate(dd%Kv_bkgnd(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_kbbl > 0) allocate(dd%kbbl(isd:ied,jsd:jed), source=0.) + if (CS%id_bbl_thick > 0) allocate(dd%bbl_thick(isd:ied,jsd:jed), source=0.) + if (CS%id_Kd_leak > 0) allocate(dd%Kd_leak(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_quad > 0) allocate(dd%Kd_quad(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_itidal > 0) allocate(dd%Kd_itidal(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_Froude > 0) allocate(dd%Kd_Froude(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_slope > 0) allocate(dd%Kd_slope(isd:ied,jsd:jed,nz+1), source=0.) + + if (CS%id_prof_leak > 0) allocate(dd%prof_leak(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_quad > 0) allocate(dd%prof_quad(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_itidal > 0) allocate(dd%prof_itidal(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_Froude > 0) allocate(dd%prof_Froude(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_slope > 0) allocate(dd%prof_slope(isd:ied,jsd:jed,nz), source=0.) + ! set up arrays for tidal mixing diagnostics if (CS%use_tidal_mixing) & call setup_tidal_diagnostics(G, GV, CS%tidal_mixing) if (CS%useKappaShear) then if (CS%debug) then - call hchksum_pair("before calc_KS [uv]_h", u_h, v_h, G%HI, scale=US%L_T_to_m_s) + call hchksum_pair("before calc_KS [uv]_h", u_h, v_h, G%HI, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then @@ -354,18 +403,18 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) if (associated(visc%Kv_shear)) visc%Kv_shear(:,:,:) = 0.0 ! needed for other parameterizations if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) - call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, scale=GV%HZ_T_to_m2_s) - call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, unscale=GV%HZ_T_to_m2_s) + call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif else ! Changes: visc%Kd_shear ; Sets: visc%Kv_shear and visc%TKE_turb call calculate_kappa_shear(u_h, v_h, h, tv, fluxes%p_surf, visc%Kd_shear, visc%TKE_turb, & visc%Kv_shear, dt, G, GV, US, CS%kappaShear_CSp) if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) - call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, scale=GV%HZ_T_to_m2_s) - call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif endif call cpu_clock_end(id_clock_kappaShear) @@ -374,8 +423,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i !NOTE{BGR}: this needs to be cleaned up. It works in 1D case, but has not been tested outside. call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear, G, GV, US, CS%CVMix_shear_CSp) if (CS%debug) then - call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) - call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, unscale=GV%HZ_T_to_m2_s) endif elseif (associated(visc%Kv_shear)) then visc%Kv_shear(:,:,:) = 0.0 ! needed if calculate_kappa_shear is not enabled @@ -384,15 +433,15 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! Smooth the properties through massless layers. if (use_EOS) then if (CS%debug) then - call hchksum(tv%T, "before vert_fill_TS tv%T", G%HI, scale=US%C_to_degC) - call hchksum(tv%S, "before vert_fill_TS tv%S", G%HI, scale=US%S_to_ppt) - call hchksum(h, "before vert_fill_TS h",G%HI, scale=GV%H_to_m) + call hchksum(tv%T, "before vert_fill_TS tv%T", G%HI, unscale=US%C_to_degC) + call hchksum(tv%S, "before vert_fill_TS tv%S", G%HI, unscale=US%S_to_ppt) + call hchksum(h, "before vert_fill_TS h",G%HI, unscale=GV%H_to_m) endif call vert_fill_TS(h, tv%T, tv%S, kappa_dt_fill, T_f, S_f, G, GV, US, larger_h_denom=.true.) if (CS%debug) then - call hchksum(tv%T, "after vert_fill_TS tv%T", G%HI, scale=US%C_to_degC) - call hchksum(tv%S, "after vert_fill_TS tv%S", G%HI, scale=US%S_to_ppt) - call hchksum(h, "after vert_fill_TS h",G%HI, scale=GV%H_to_m) + call hchksum(tv%T, "after vert_fill_TS tv%T", G%HI, unscale=US%C_to_degC) + call hchksum(tv%S, "after vert_fill_TS tv%S", G%HI, unscale=US%S_to_ppt) + call hchksum(h, "after vert_fill_TS h",G%HI, unscale=GV%H_to_m) endif endif @@ -401,12 +450,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! parameterization of Kd. !$OMP parallel do default(shared) private(dRho_int,N2_lay,Kd_lay_2d,Kd_int_2d,Kv_bkgnd,N2_int,dz, & - !$OMP N2_bot,rho_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb) & + !$OMP N2_bot,rho_bot,h_bot,k_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb) & !$OMP if(.not. CS%use_CVMix_ddiff) do j=js,je ! Set up variables related to the stratification. - call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot, rho_bot) + call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot, rho_bot, h_bot, k_bot) if (associated(dd%N2_3d)) then do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo @@ -515,6 +564,53 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i maxTKE, G, GV, US, CS%tidal_mixing, & CS%Kd_max, visc%Kv_slow, Kd_lay_2d, Kd_int_2d) + ! Add diffusivity from internal tides ray tracing + if (CS%use_int_tides) then + + call get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2_int, TKE_to_Kd, CS%Kd_max, & + CS%int_tide_CSp, Kd_leak_2d, Kd_quad_2d, Kd_itidal_2d, Kd_Froude_2d, Kd_slope_2d, & + Kd_lay_2d, Kd_int_2d, prof_leak_2d, prof_quad_2d, prof_itidal_2d, prof_froude_2d, & + prof_slope_2d) + + if (CS%id_kbbl > 0) then ; do i=is,ie + dd%kbbl(i,j) = k_bot(i) + enddo ; endif + if (CS%id_bbl_thick > 0) then ; do i=is,ie + dd%bbl_thick(i,j) = h_bot(i) + enddo ; endif + if (CS%id_Kd_leak > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_leak(i,j,K) = Kd_leak_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_quad > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_quad(i,j,K) = Kd_quad_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_itidal > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_itidal(i,j,K) = Kd_itidal_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_Froude > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_Froude(i,j,K) = Kd_Froude_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_slope > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_slope(i,j,K) = Kd_slope_2d(i,K) + enddo ; enddo ; endif + + if (CS%id_prof_leak > 0) then ; do k=1,nz; do i=is,ie + dd%prof_leak(i,j,k) = prof_leak_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_quad > 0) then ; do k=1,nz; do i=is,ie + dd%prof_quad(i,j,k) = prof_quad_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_itidal > 0) then ; do k=1,nz; do i=is,ie + dd%prof_itidal(i,j,k) = prof_itidal_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_Froude > 0) then ; do k=1,nz; do i=is,ie + dd%prof_Froude(i,j,k) = prof_Froude_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_slope > 0) then ; do k=1,nz; do i=is,ie + dd%prof_slope(i,j,k) = prof_slope_2d(i,k) + enddo ; enddo ; endif + endif + ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then if (CS%use_LOTW_BBL_diffusivity) then @@ -591,34 +687,48 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif if (CS%debug) then - if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) - if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) if (CS%use_CVMix_ddiff) then - call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) then call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & - haloshift=0, symmetric=.true., scale=GV%HZ_T_to_m2_s, & + haloshift=0, symmetric=.true., unscale=GV%HZ_T_to_m2_s, & scalar_pair=.true.) endif if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) then call uvchksum("BBL bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & - G%HI, haloshift=0, symmetric=.true., scale=US%Z_to_m, & + G%HI, haloshift=0, symmetric=.true., unscale=US%Z_to_m, & scalar_pair=.true.) endif if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) then call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, & - symmetric=.true., scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) + symmetric=.true., unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) endif endif + if (CS%debug) then + if (CS%id_prof_leak > 0) call hchksum(dd%prof_leak, "leakage_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_slope > 0) call hchksum(dd%prof_slope, "slope_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_Froude > 0) call hchksum(dd%prof_Froude, "Froude_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_quad > 0) call hchksum(dd%prof_quad, "quad_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_itidal > 0) call hchksum(dd%prof_itidal, "itidal_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_TKE_to_Kd > 0) call hchksum(dd%TKE_to_Kd, "TKE_to_Kd", G%HI, haloshift=0, scale=US%m_to_Z*US%T_to_s**2) + if (CS%id_Kd_leak > 0) call hchksum(dd%Kd_leak, "Kd_leak", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_quad > 0) call hchksum(dd%Kd_quad, "Kd_quad", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_itidal > 0) call hchksum(dd%Kd_itidal, "Kd_itidal", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_Froude > 0) call hchksum(dd%Kd_Froude, "Kd_Froude", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_slope > 0) call hchksum(dd%Kd_slope, "Kd_slope", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + ! post diagnostics if (present(Kd_lay) .and. (CS%id_Kd_layer > 0)) call post_data(CS%id_Kd_layer, Kd_lay, CS%diag) @@ -626,6 +736,20 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%id_Kd_bkgnd > 0) call post_data(CS%id_Kd_bkgnd, dd%Kd_bkgnd, CS%diag) if (CS%id_Kv_bkgnd > 0) call post_data(CS%id_Kv_bkgnd, dd%Kv_bkgnd, CS%diag) + if (CS%id_kbbl > 0) call post_data(CS%id_kbbl, dd%kbbl, CS%diag) + if (CS%id_bbl_thick > 0) call post_data(CS%id_bbl_thick, dd%bbl_thick, CS%diag) + if (CS%id_Kd_leak > 0) call post_data(CS%id_Kd_leak, dd%Kd_leak, CS%diag) + if (CS%id_Kd_slope > 0) call post_data(CS%id_Kd_slope, dd%Kd_slope, CS%diag) + if (CS%id_Kd_Froude > 0) call post_data(CS%id_Kd_Froude, dd%Kd_Froude, CS%diag) + if (CS%id_Kd_quad > 0) call post_data(CS%id_Kd_quad, dd%Kd_quad, CS%diag) + if (CS%id_Kd_itidal > 0) call post_data(CS%id_Kd_itidal, dd%Kd_itidal, CS%diag) + + if (CS%id_prof_leak > 0) call post_data(CS%id_prof_leak, dd%prof_leak, CS%diag) + if (CS%id_prof_slope > 0) call post_data(CS%id_prof_slope, dd%prof_slope, CS%diag) + if (CS%id_prof_Froude > 0) call post_data(CS%id_prof_Froude, dd%prof_Froude, CS%diag) + if (CS%id_prof_quad > 0) call post_data(CS%id_prof_quad, dd%prof_quad, CS%diag) + if (CS%id_prof_itidal > 0) call post_data(CS%id_prof_itidal, dd%prof_itidal, CS%diag) + ! tidal mixing if (CS%use_tidal_mixing) & call post_tidal_diagnostics(G, GV, h, CS%tidal_mixing) @@ -660,6 +784,17 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (associated(dd%Kd_bkgnd)) deallocate(dd%Kd_bkgnd) if (associated(dd%Kv_bkgnd)) deallocate(dd%Kv_bkgnd) + if (associated(dd%Kd_leak)) deallocate(dd%Kd_leak) + if (associated(dd%Kd_quad)) deallocate(dd%Kd_quad) + if (associated(dd%Kd_itidal)) deallocate(dd%Kd_itidal) + if (associated(dd%Kd_Froude)) deallocate(dd%Kd_Froude) + if (associated(dd%Kd_slope)) deallocate(dd%Kd_slope) + if (associated(dd%prof_leak)) deallocate(dd%prof_leak) + if (associated(dd%prof_quad)) deallocate(dd%prof_quad) + if (associated(dd%prof_itidal)) deallocate(dd%prof_itidal) + if (associated(dd%prof_Froude)) deallocate(dd%prof_Froude) + if (associated(dd%prof_slope)) deallocate(dd%prof_slope) + if (showCallTree) call callTree_leave("set_diffusivity()") end subroutine set_diffusivity @@ -890,7 +1025,7 @@ end subroutine find_TKE_to_Kd !> Calculate Brunt-Vaisala frequency, N^2. subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & - N2_lay, N2_int, N2_bot, Rho_bot) + N2_lay, N2_int, N2_bot, Rho_bot, h_bot, k_bot) 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 @@ -916,6 +1051,8 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [T-2 ~> s-2]. real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [T-2 ~> s-2]. real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + real, dimension(SZI_(G)), optional, intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2]. + integer, dimension(SZI_(G)), optional, intent(out) :: k_bot !< Bottom boundary layer top layer index. ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & @@ -1060,13 +1197,13 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & ! Average over the larger of the envelope of the topography or a minimal distance. do i=is,ie ; dz_BBL_avg(i) = max(h_amp(i), CS%dz_BBL_avg_min) ; enddo - call find_rho_bottom(h, dz, pres, dz_BBL_avg, tv, j, G, GV, US, Rho_bot) + call find_rho_bottom(G, GV, US, tv, h, dz, pres, dz_BBL_avg, j, Rho_bot, h_bot, k_bot) end subroutine find_N2 !> This subroutine sets the additional diffusivities of temperature and !! salinity due to double diffusion, using the same functional form as is -!! used in MOM4.1, and taken from an NCAR technical note (REF?) that updates +!! used in MOM4.1, and taken from the appendix of Danabasoglu et al. (2006), which updates !! what was in Large et al. (1994). All the coefficients here should probably !! be made run-time variables rather than hard-coded constants. !! @@ -1109,8 +1246,6 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) real :: Kd_dd ! The dominant double diffusive diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: prandtl ! flux ratio for diffusive convection regime [nondim] - real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio [nondim] - integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1136,8 +1271,8 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) beta_dS = dRho_dS(i) * (S_f(i,j,k-1) - S_f(i,j,k)) if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then ! salt finger case - Rrho = min(alpha_dT / beta_dS, Rrho0) - diff_dd = 1.0 - ((RRho-1.0)/(RRho0-1.0)) + Rrho = min(alpha_dT / beta_dS, CS%Max_Rrho_salt_fingers) + diff_dd = 1.0 - ((RRho-1.0)/(CS%Max_Rrho_salt_fingers-1.0)) Kd_dd = CS%Max_salt_diff_salt_fingers * diff_dd*diff_dd*diff_dd Kd_T_dd(i,K) = 0.7 * Kd_dd Kd_S_dd(i,K) = Kd_dd @@ -1426,6 +1561,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo ! Local variables real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: dz_above(SZK_(GV)+1) ! Distance from each interface to the surface [Z ~> m] real :: TKE_column ! net TKE input into the column [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_consumed ! TKE used for mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] @@ -1500,7 +1636,15 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column - total_depth = ( sum(dz(i,:)) + GV%dz_subroundoff ) ! Total column thickness [Z ~> m]. + if (CS%LOTW_BBL_answer_date > 20240630) then + dz_above(1) = GV%dz_subroundoff ! This could perhaps be 0 instead. + do K=2,GV%ke+1 + dz_above(K) = dz_above(K-1) + dz(i,k-1) + enddo + total_depth = dz_above(GV%ke+1) + else + total_depth = ( sum(dz(i,:)) + GV%dz_subroundoff ) ! Total column thickness [Z ~> m]. + endif ustar_D = ustar * total_depth h_bot = 0. z_bot = 0. @@ -1525,7 +1669,11 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo z_bot = z_bot + dz(i,k) ! Distance between upper interface of layer and the bottom [Z ~> m]. h_bot = h_bot + h(i,j,k) ! Thickness between upper interface of layer and the bottom [H ~> m or kg m-2]. - D_minus_z = max(total_depth - z_bot, 0.) ! Thickness above layer [H ~> m or kg m-2]. + if (CS%LOTW_BBL_answer_date > 20240630) then + D_minus_z = dz_above(K) + else + D_minus_z = max(total_depth - z_bot, 0.) ! Distance from the interface to the surface [Z ~> m]. + endif ! Diffusivity using law of the wall, limited by rotation, at height z [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This calculation is at the upper interface of the layer @@ -2098,7 +2246,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed CS%diag => diag - if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp + CS%int_tide_CSp => int_tide_CSp ! These default values always need to be set. CS%BBL_mixing_as_max = .true. @@ -2191,7 +2339,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "law of the form c_drag*|u|*u. The velocity magnitude "//& "may be an assumed value or it may be based on the actual "//& "velocity in the bottommost HBBL, depending on LINEAR_DRAG.", default=.true.) - if (CS%bottomdraglaw) then + if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "The drag coefficient relating the magnitude of the "//& "velocity field to the bottom stress. CDRAG is only used "//& @@ -2231,6 +2379,14 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ else CS%use_LOTW_BBL_diffusivity = .false. ! This parameterization depends on a u* from viscous BBL endif + call get_param(param_file, mdl, "LOTW_BBL_ANSWER_DATE", CS%LOTW_BBL_answer_date, & + "The vintage of the order of arithmetic and expressions in the LOTW_BBL "//& + "calculations. Values below 20240630 recover the original answers, while "//& + "higher values use more accurate expressions. This only applies when "//& + "USE_LOTW_BBL_DIFFUSIVITY is true.", & + default=20190101, do_not_log=.not.CS%use_LOTW_BBL_diffusivity) + !### Set default as default=default_answer_date, or use SET_DIFF_ANSWER_DATE. + CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) @@ -2247,6 +2403,10 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "for an isopycnal layer-formulation.", & default=.false., do_not_log=.not.TKE_to_Kd_used) + call get_param(param_file, mdl, "INTERNAL_TIDES", CS%use_int_tides, & + "If true, use the code that advances a separate set of "//& + "equations for the internal tide energy density.", default=.false.) + ! set parameters related to the background mixing call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp, physical_OBL_scheme) @@ -2324,6 +2484,33 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%id_Kv_bkgnd = register_diag_field('ocean_model', 'Kv_bkgnd', diag%axesTi, Time, & 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + if (CS%use_int_tides) then + CS%id_kbbl = register_diag_field('ocean_model', 'kbbl', diag%axesT1, Time, & + 'BBL index at h points', 'nondim') + CS%id_bbl_thick = register_diag_field('ocean_model', 'bbl_thick', diag%axesT1, Time, & + 'BBL thickness at h points', 'm', conversion=US%Z_to_m) + CS%id_Kd_leak = register_diag_field('ocean_model', 'Kd_leak', diag%axesTi, Time, & + 'internal tides leakage viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_Froude = register_diag_field('ocean_model', 'Kd_Froude', diag%axesTi, Time, & + 'internal tides Froude viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_itidal = register_diag_field('ocean_model', 'Kd_itidal', diag%axesTi, Time, & + 'internal tides wave drag viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_quad = register_diag_field('ocean_model', 'Kd_quad', diag%axesTi, Time, & + 'internal tides bottom viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_slope = register_diag_field('ocean_model', 'Kd_slope', diag%axesTi, Time, & + 'internal tides slope viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_prof_leak = register_diag_field('ocean_model', 'prof_leak', diag%axesTl, Time, & + 'internal tides leakage profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_Froude = register_diag_field('ocean_model', 'prof_Froude', diag%axesTl, Time, & + 'internal tides Froude profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_itidal = register_diag_field('ocean_model', 'prof_itidal', diag%axesTl, Time, & + 'internal tides wave drag profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_quad = register_diag_field('ocean_model', 'prof_quad', diag%axesTl, Time, & + 'internal tides bottom profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_slope = register_diag_field('ocean_model', 'prof_slope', diag%axesTl, Time, & + 'internal tides slope profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + endif + CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) @@ -2352,7 +2539,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ if (CS%double_diffusion) then call get_param(param_file, mdl, "MAX_RRHO_SALT_FINGERS", CS%Max_Rrho_salt_fingers, & "Maximum density ratio for salt fingering regime.", & - default=2.55, units="nondim") + default=1.9, units="nondim") call get_param(param_file, mdl, "MAX_SALT_DIFF_SALT_FINGERS", CS%Max_salt_diff_salt_fingers, & "Maximum salt diffusivity for salt fingering regime.", & default=1.e-4, units="m2 s-1", scale=GV%m2_s_to_HZ_T) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 7687d91e17..ff97e616d9 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -321,16 +321,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (.not.CS%bottomdraglaw) return if (CS%debug) then - call uvchksum("Start set_viscous_BBL [uv]", u, v, G%HI, haloshift=1, scale=US%L_T_to_m_s) - call hchksum(h,"Start set_viscous_BBL h", G%HI, haloshift=1, scale=GV%H_to_m) - if (associated(tv%T)) call hchksum(tv%T, "Start set_viscous_BBL T", G%HI, haloshift=1, scale=US%C_to_degC) - if (associated(tv%S)) call hchksum(tv%S, "Start set_viscous_BBL S", G%HI, haloshift=1, scale=US%S_to_ppt) + call uvchksum("Start set_viscous_BBL [uv]", u, v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) + call hchksum(h,"Start set_viscous_BBL h", G%HI, haloshift=1, unscale=GV%H_to_m) + if (associated(tv%T)) call hchksum(tv%T, "Start set_viscous_BBL T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Start set_viscous_BBL S", G%HI, haloshift=1, unscale=US%S_to_ppt) if (allocated(tv%SpV_avg)) & - call hchksum(tv%SpV_avg, "Start set_viscous_BBL SpV_avg", G%HI, haloshift=1, scale=US%kg_m3_to_R) + call hchksum(tv%SpV_avg, "Start set_viscous_BBL SpV_avg", G%HI, haloshift=1, unscale=US%kg_m3_to_R) if (allocated(tv%SpV_avg)) call hchksum(tv%SpV_avg, "Cornerless SpV_avg", G%HI, & - haloshift=1, omit_corners=.true., scale=US%kg_m3_to_R) - if (associated(tv%T)) call hchksum(tv%T, "Cornerless T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) - if (associated(tv%S)) call hchksum(tv%S, "Cornerless S", G%HI, haloshift=1, omit_corners=.true., scale=US%S_to_ppt) + haloshift=1, omit_corners=.true., unscale=US%kg_m3_to_R) + if (associated(tv%T)) call hchksum(tv%T, "Cornerless T", G%HI, haloshift=1, & + omit_corners=.true., unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Cornerless S", G%HI, haloshift=1, & + omit_corners=.true., unscale=US%S_to_ppt) endif use_BBL_EOS = associated(tv%eqn_of_state) .and. CS%BBL_use_EOS @@ -1088,13 +1090,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (CS%debug) then if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) & call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, & - scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) + unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) & call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & - haloshift=0, scale=GV%HZ_T_to_m2_s, scalar_pair=.true.) + haloshift=0, unscale=GV%HZ_T_to_m2_s, scalar_pair=.true.) if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) & call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & - G%HI, haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) + G%HI, haloshift=0, unscale=US%Z_to_m, scalar_pair=.true.) endif end subroutine set_viscous_BBL diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 31f90cdcb1..5b57103078 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -602,7 +602,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di local_mixing_frac = CS%Gamma_itides, & depth_cutoff = CS%min_zbot_itides*US%Z_to_m) - call read_tidal_energy(G, US, tidal_energy_type, param_file, CS) + call read_tidal_energy(G, GV, US, tidal_energy_type, param_file, CS) !call closeParameterBlock(param_file) @@ -912,7 +912,7 @@ subroutine calculate_CVMix_tidal(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_in ! remap from input z coordinate to model coordinate: tidal_qe_md(:) = 0.0 call remapping_core_h(CS%remap_cs, size(CS%h_src), CS%h_src, CS%tidal_qe_3d_in(i,j,:), & - GV%ke, h_m, tidal_qe_md, GV%H_subroundoff, GV%H_subroundoff) + GV%ke, h_m, tidal_qe_md) ! form the Schmittner coefficient that is based on 3D q*E, which is formed from ! summing q_i*TidalConstituent_i over the number of constituents. @@ -1571,8 +1571,9 @@ end subroutine tidal_mixing_h_amp ! TODO: move this subroutine to MOM_internal_tide_input module (?) !> This subroutine read tidal energy inputs from a file. -subroutine read_tidal_energy(G, US, tidal_energy_type, param_file, CS) +subroutine read_tidal_energy(G, GV, US, tidal_energy_type, param_file, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=20), intent(in) :: tidal_energy_type !< The type of tidal energy inputs to read type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle @@ -1606,7 +1607,7 @@ subroutine read_tidal_energy(G, US, tidal_energy_type, param_file, CS) enddo ; enddo deallocate(tidal_energy_flux_2d) case ('ER03') ! Egbert & Ray 2003 - call read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) + call read_tidal_constituents(G, GV, US, tidal_energy_file, param_file, CS) case default call MOM_error(FATAL, "read_tidal_energy: Unknown tidal energy file type.") end select @@ -1614,8 +1615,9 @@ subroutine read_tidal_energy(G, US, tidal_energy_type, param_file, CS) end subroutine read_tidal_energy !> This subroutine reads tidal input energy from a file by constituent. -subroutine read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) +subroutine read_tidal_constituents(G, GV, US, tidal_energy_file, param_file, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=200), intent(in) :: tidal_energy_file !< The file from which to read tidal energy inputs type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle @@ -1700,7 +1702,8 @@ subroutine read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) ! initialize input remapping: call initialize_remapping(CS%remap_cs, remapping_scheme="PLM", & boundary_extrapolation=.false., check_remapping=CS%debug, & - answer_date=CS%remap_answer_date) + answer_date=CS%remap_answer_date, & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) deallocate(tc_m2) deallocate(tc_s2) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index b1556aa42d..f119ccb040 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -616,7 +616,7 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va !! otherwise they are v-points. ! local variables - logical :: kdgl90_use_ebt_struct + logical :: kdgl90_use_vert_struct ! use vertical structure for GL90 coefficient integer :: i, k, is, ie, nz, Isq, Ieq real :: f2 !< Squared Coriolis parameter at a velocity grid point [T-2 ~> s-2]. real :: h_neglect ! A vertical distance that is so small it is usually lost in roundoff error @@ -629,9 +629,9 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va nz = GV%ke h_neglect = GV%dZ_subroundoff - kdgl90_use_ebt_struct = .false. + kdgl90_use_vert_struct = .false. if (VarMix%use_variable_mixing) then - kdgl90_use_ebt_struct = VarMix%kdgl90_use_ebt_struct + kdgl90_use_vert_struct = allocated(VarMix%kdgl90_struct) endif if (work_on_u) then @@ -647,8 +647,9 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va else a_cpl_gl90(I,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) endif - if (kdgl90_use_ebt_struct) then - a_cpl_gl90(I,K) = a_cpl_gl90(I,K) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + if (kdgl90_use_vert_struct) then + a_cpl_gl90(I,K) = a_cpl_gl90(I,K) * 0.5 * & + ( VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i+1,j,k-1) ) endif endif ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, @@ -671,8 +672,9 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va else a_cpl_gl90(i,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) endif - if (kdgl90_use_ebt_struct) then - a_cpl_gl90(i,K) = a_cpl_gl90(i,K) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + if (kdgl90_use_vert_struct) then + a_cpl_gl90(i,K) = a_cpl_gl90(i,K) * 0.5 * & + ( VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i,j+1,k-1) ) endif endif ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, @@ -1886,12 +1888,12 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, if (CS%debug) then call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, & - scale=GV%H_to_m, scalar_pair=.true.) + unscale=GV%H_to_m, scalar_pair=.true.) call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, & - scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) + unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) if (allocated(hML_u) .and. allocated(hML_v)) & call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, & - haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) + haloshift=0, unscale=US%Z_to_m, scalar_pair=.true.) endif ! Offer diagnostic fields for averaging. diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index e0bd659a60..76546f834c 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -372,7 +372,7 @@ subroutine DOME_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 64db56b96c..cc4dca16bc 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -331,7 +331,7 @@ subroutine ISOMIP_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index ef11739f33..fe20daaefd 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -565,7 +565,7 @@ subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US if (CS%debug) then do m=1,NTR call hchksum(CS%CFC_data(m)%sfc_flux, trim(CS%CFC_data(m)%name)//" sfc_flux", G%HI, & - scale=US%RZ_T_to_kg_m2s) + unscale=US%RZ_T_to_kg_m2s) enddo endif diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 50354b5dc7..7947cc72ed 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -453,9 +453,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 with the scaling factors changes ! the units of the flux from [Conc. m s-1] to [Conc. R Z T-1 ~> Conc. kg m-2 s-1]. call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, CFC11_flux, & - scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim, turns=G%HI%turns) call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, CFC12_flux, & - scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim, turns=G%HI%turns) ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. @@ -587,13 +587,13 @@ subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, US, CS) ! These calls load these values into the appropriate arrays in the ! coupler-type structure. call set_coupler_type_data(CFC11_alpha, CS%ind_cfc_11_flux, sfc_state%tr_fields, & - solubility=.true., idim=idim, jdim=jdim) + solubility=.true., idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC11_Csurf, CS%ind_cfc_11_flux, sfc_state%tr_fields, & - idim=idim, jdim=jdim) + idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC12_alpha, CS%ind_cfc_12_flux, sfc_state%tr_fields, & - solubility=.true., idim=idim, jdim=jdim) + solubility=.true., idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC12_Csurf, CS%ind_cfc_12_flux, sfc_state%tr_fields, & - idim=idim, jdim=jdim) + idim=idim, jdim=jdim, turns=G%HI%turns) end subroutine OCMIP2_CFC_surface_state diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index f430e94515..6b10d15e2f 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -44,7 +44,7 @@ module MOM_generic_tracer use MOM_open_boundary, only : register_obgc_segments, fill_obgc_segments use MOM_open_boundary, only : set_obgc_segments_props use MOM_restart, only : register_restart_field, query_initialized, set_initialized, MOM_restart_CS - use MOM_spatial_means, only : global_area_mean, global_mass_int_EFP + use MOM_spatial_means, only : global_area_mean, global_mass_int_EFP, array_global_min_max use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, set_time use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut @@ -206,7 +206,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? tr_ptr => tr_field(:,:,:,1) - ! Register prognastic tracer for horizontal advection, diffusion, and restarts. + ! Register prognostic tracer for horizontal advection, diffusion, and restarts. if (g_tracer_is_prog(g_tracer)) then call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=g_tracer_name, longname=longname, units=units, & @@ -570,7 +570,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, surface_field(i,j) = tv%S(i,j,1) dz_ml(i,j) = US%Z_to_m * Hml(i,j) enddo ; enddo - sosga = global_area_mean(surface_field, G, scale=US%S_to_ppt) + sosga = global_area_mean(surface_field, G, unscale=US%S_to_ppt) ! !Calculate tendencies (i.e., field changes at dt) from the sources / sinks @@ -584,13 +584,24 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & internal_heat=tv%internal_heat, frunoff=fluxes%frunoff, sosga=sosga) else - call generic_tracer_source(US%C_to_degC*tv%T, US%S_to_ppt*tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & + ! tv%internal_heat is a null pointer unless DO_GEOTHERMAL = True, + ! so we have to check and only do the scaling if it is associated. + if(associated(tv%internal_heat)) then + call generic_tracer_source(US%C_to_degC*tv%T, US%S_to_ppt*tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & optics%nbands, optics%max_wavelength_band, & sw_pen_band=G%US%QRZ_T_to_W_m2*optics%sw_pen_band(:,:,:), & opacity_band=G%US%m_to_Z*optics%opacity_band(:,:,:,:), & internal_heat=G%US%RZ_to_kg_m2*US%C_to_degC*tv%internal_heat(:,:), & frunoff=G%US%RZ_T_to_kg_m2s*fluxes%frunoff(:,:), sosga=sosga) + else + call generic_tracer_source(US%C_to_degC*tv%T, US%S_to_ppt*tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & + G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & + optics%nbands, optics%max_wavelength_band, & + sw_pen_band=G%US%QRZ_T_to_W_m2*optics%sw_pen_band(:,:,:), & + opacity_band=G%US%m_to_Z*optics%opacity_band(:,:,:,:), & + frunoff=G%US%RZ_T_to_kg_m2s*fluxes%frunoff(:,:), sosga=sosga) + endif endif ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes @@ -699,42 +710,49 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde end function MOM_generic_tracer_stock - !> This subroutine find the global min and max of either of all - !! available tracer concentrations, or of a tracer that is being - !! requested specifically, returning the number of tracers it has gone through. - function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, ygmin, zgmin, & - xgmax, ygmax, zgmax , G, CS, names, units) + !> This subroutine finds the global min and max of either of all available + !! tracer concentrations, or of a tracer that is being requested specifically, + !! returning the number of tracers it has evaluated. + !! It also optionally returns the locations of the extrema. + function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, G, CS, names, units, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) integer, intent(in) :: ind_start !< The index of the tracer to start with logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and !! max are found for each tracer - real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: xgmin !< The x-position of the global minimum - real, dimension(:), intent(out) :: ygmin !< The y-position of the global minimum - real, dimension(:), intent(out) :: zgmin !< The z-position of the global minimum - real, dimension(:), intent(out) :: xgmax !< The x-position of the global maximum - real, dimension(:), intent(out) :: ygmax !< The y-position of the global maximum - real, dimension(:), intent(out) :: zgmax !< The z-position of the global maximum + real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer [conc] + real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer [conc] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] integer :: MOM_generic_tracer_min_max !< Return value, the !! number of tracers done here. -! Local variables + ! Local variables type(g_tracer_type), pointer :: g_tracer, g_tracer_next - real, dimension(:,:,:,:), pointer :: tr_field - real, dimension(:,:,:), pointer :: tr_ptr + real, dimension(:,:,:,:), pointer :: tr_field ! The tracer array whose extrema are being sought [conc] + real, dimension(:,:,:), pointer :: tr_ptr ! The tracer array whose extrema are being sought [conc] + real :: x_min ! The x-position of the global minimum in the units of G%geoLonT, often [degrees_E] or [km] or [m] + real :: y_min ! The y-position of the global minimum in the units of G%geoLatT, often [degrees_N] or [km] or [m] + real :: z_min ! The z-position of the global minimum [layer] + real :: x_max ! The x-position of the global maximum in the units of G%geoLonT, often [degrees_E] or [km] or [m] + real :: y_max ! The y-position of the global maximum in the units of G%geoLatT, often [degrees_N] or [km] or [m] + real :: z_max ! The z-position of the global maximum [layer] character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' - real, dimension(:,:,:),pointer :: grid_tmask - integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau - + logical :: find_location + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, nk, ntau integer :: k, is, ie, js, je, m - real, allocatable, dimension(:) :: geo_z is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -743,19 +761,14 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. - - call g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,grid_tmask=grid_tmask) - - ! Because the use of a simple z-coordinate can not be assumed, simply - ! use the layer index as the vertical label. - allocate(geo_z(nk)) - do k=1,nk ; geo_z(k) = real(k) ; enddo + call g_tracer_get_common(isc, iec, jsc, jec, isd, ied, jsd, jed, nk, ntau) + find_location = present(xgmin) .or. present(ygmin) .or. present(zgmin) .or. & + present(xgmax) .or. present(ygmax) .or. present(zgmax) m=ind_start ; g_tracer=>CS%g_tracer_list do call g_tracer_get_alias(g_tracer,names(m)) call g_tracer_get_values(g_tracer,names(m),'units',units(m)) - units(m) = trim(units(m))//" kg" call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) gmin(m) = -1.0 @@ -763,9 +776,18 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg tr_ptr => tr_field(:,:,:,1) - call array_global_min_max(tr_ptr, grid_tmask, isd, jsd, isc, iec, jsc, jec, nk, gmin(m), gmax(m), & - G%geoLonT, G%geoLatT, geo_z, xgmin(m), ygmin(m), zgmin(m), & - xgmax(m), ygmax(m), zgmax(m)) + if (find_location) then + call array_global_min_max(tr_ptr, G, nk, gmin(m), gmax(m), & + x_min, y_min, z_min, x_max, y_max, z_max) + if (present(xgmin)) xgmin(m) = x_min + if (present(ygmin)) ygmin(m) = y_min + if (present(zgmin)) zgmin(m) = z_min + if (present(xgmax)) xgmax(m) = x_max + if (present(ygmax)) ygmax(m) = y_max + if (present(zgmax)) zgmax(m) = z_max + else + call array_global_min_max(tr_ptr, G, nk, gmin(m), gmax(m)) + endif got_minmax(m) = .true. @@ -780,133 +802,6 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg end function MOM_generic_tracer_min_max - !> Find the global maximum and minimum of a tracer array and return the locations of the extrema. - subroutine array_global_min_max(tr_array, tmask, isd, jsd, isc, iec, jsc, jec, nk, g_min, g_max, & - geo_x, geo_y, geo_z, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) - integer, intent(in) :: isd !< The starting data domain i-index - integer, intent(in) :: jsd !< The starting data domain j-index - real, dimension(isd:,jsd:,:), intent(in) :: tr_array !< The tracer array to search for extrema - real, dimension(isd:,jsd:,:), intent(in) :: tmask !< A mask that is 0 for points to exclude - integer, intent(in) :: isc !< The starting compute domain i-index - integer, intent(in) :: iec !< The ending compute domain i-index - integer, intent(in) :: jsc !< The starting compute domain j-index - integer, intent(in) :: jec !< The ending compute domain j-index - integer, intent(in) :: nk !< The number of vertical levels - real, intent(out) :: g_min !< The global minimum of tr_array - real, intent(out) :: g_max !< The global maximum of tr_array - real, dimension(isd:,jsd:), intent(in) :: geo_x !< The geographic x-positions of points - real, dimension(isd:,jsd:), intent(in) :: geo_y !< The geographic y-positions of points - real, dimension(:), intent(in) :: geo_z !< The vertical pseudo-positions of points - real, intent(out) :: xgmin !< The x-position of the global minimum - real, intent(out) :: ygmin !< The y-position of the global minimum - real, intent(out) :: zgmin !< The z-position of the global minimum - real, intent(out) :: xgmax !< The x-position of the global maximum - real, intent(out) :: ygmax !< The y-position of the global maximum - real, intent(out) :: zgmax !< The z-position of the global maximum - - ! This subroutine is an exact transcription (bugs and all) of mpp_array_global_min_max() - ! from the version in FMS/mpp/mpp_utilities.F90, but with some whitespace changes to match - ! MOM6 code styles and to use infrastructure routines via the MOM6 framework code, and with - ! added comments to document its arguments.i - - !### The obvious problems with this routine as currently written include: - ! 1. It does not return exactly the maximum and minimum values. - ! 2. The reported maximum and minimum are dependent on PE count and layout. - ! 3. For all-zero arrays, the reported maxima scale with the PE_count - ! 4. For arrays with a large enough offset or scaling, so that the magnitude of values exceed - ! 1e10, the values it returns are simply wrong. - ! 5. The results do not scale appropriately if the argument is rescaled. - ! 6. The extrema and locations are not rotationally invariant. - ! 7. It is inefficient because it uses 8 blocking global reduction calls when it could use just 2 or 3. - - ! Local variables - real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array - real :: tmax0, tmin0 ! First-guest values of tmax and tmin. - integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin - real :: fudge ! A factor that is close to 1 that is used to find the location of the extrema [nondim]. - - ! arrays to enable vectorization - integer :: iminarr(3), imaxarr(3) - - !### These dimensional constant values mean that the results can not be guaranteed to be rescalable. - g_min = -88888888888.0 ; g_max = -999999999.0 - tmax = -1.e10 ; tmin = 1.e10 - itmax = 0 ; jtmax = 0 ; ktmax = 0 - itmin = 0 ; jtmin = 0 ; ktmin = 0 - - if (ANY(tmask(isc:iec,jsc:jec,:) > 0.)) then - ! Vectorized using maxloc() and minloc() intrinsic functions by Russell.Fiedler@csiro.au. - iminarr = minloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) - imaxarr = maxloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) - itmin = iminarr(1)+isc-1 - jtmin = iminarr(2)+jsc-1 - ktmin = iminarr(3) - itmax = imaxarr(1)+isc-1 - jtmax = imaxarr(2)+jsc-1 - ktmax = imaxarr(3) - tmin = tr_array(itmin,jtmin,ktmin) - tmax = tr_array(itmax,jtmax,ktmax) - end if - - ! use "fudge" to distinguish processors when tracer extreme is independent of processor - !### This fudge factor is not independent of PE layout, and while it mostly works for finding - ! a positive maximum or a negative minimum, it could miss the true extrema in the opposite - ! cases, for which the fudge factor should be slightly reduced. The fudge factor should - ! be based on global index-space conventions, which are decomposition invariant, and - ! not the PE-number! - fudge = 1.0 + 1.e-12*real(PE_here() ) - tmax = tmax*fudge - tmin = tmin*fudge - if (tmax == 0.0) then - tmax = tmax + 1.e-12*real(PE_here() ) - endif - if (tmin == 0.0) then - tmin = tmin + 1.e-12*real(PE_here() ) - endif - - tmax0 = tmax ; tmin0 = tmin - - call max_across_PEs(tmax) - call min_across_PEs(tmin) - - g_max = tmax - g_min = tmin - - ! Now find the location of the global extrema. - ! - ! Note that the fudge factor above guarantees that the location of max (min) is unique, - ! since tmax0 (tmin0) has slightly different values on each processor. - ! Otherwise, the function tr_array(i,j,k) could be equal to global max (min) at more - ! than one point in space and this would be a much more difficult problem to solve. - ! - !-999 on all current PE's - xgmax = -999. ; ygmax = -999. ; zgmax = -999. - xgmin = -999. ; ygmin = -999. ; zgmin = -999. - - if (tmax0 == tmax) then !This happens ONLY on ONE processor because of fudge factor above. - xgmax = geo_x(itmax,jtmax) - ygmax = geo_y(itmax,jtmax) - zgmax = geo_z(ktmax) - endif - - !### These three calls and the three calls that follow in about 10 lines should be combined - ! into a single call for efficiency. - call max_across_PEs(xgmax) - call max_across_PEs(ygmax) - call max_across_PEs(zgmax) - - if (tmin0 == tmin) then !This happens ONLY on ONE processor because of fudge factor above. - xgmin = geo_x(itmin,jtmin) - ygmin = geo_y(itmin,jtmin) - zgmin = geo_z(ktmin) - endif - - call max_across_PEs(xgmin) - call max_across_PEs(ygmin) - call max_across_PEs(zgmin) - - end subroutine array_global_min_max - !> This subroutine calculates the surface state and sets coupler values for !! those generic tracers that have flux exchange with atmosphere. !! @@ -933,7 +828,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) dzt(:,:,:) = GV%H_to_m * h(:,:,:) - sosga = global_area_mean(sfc_state%SSS, G, scale=G%US%S_to_ppt) + sosga = global_area_mean(sfc_state%SSS, G, unscale=G%US%S_to_ppt) if ((G%US%C_to_degC == 1.0) .and. (G%US%S_to_ppt == 1.0)) then call generic_tracer_coupler_set(sfc_state%tr_fields, & @@ -983,7 +878,7 @@ subroutine MOM_generic_flux_init(verbosity) g_tracer=>g_tracer_list do - call g_tracer_flux_init(g_tracer) !, verbosity=verbosity) !### Add this after ocean shared is updated. + call g_tracer_flux_init(g_tracer, verbosity=verbosity) ! traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index 13e91e8973..6d8fe881d1 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -89,6 +89,7 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba ! local variables character(len=80) :: string ! Temporary strings logical :: boundary_extrap ! controls if boundary extrapolation is used in the HBD code + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for HBD logical :: debug !< If true, write verbose checksums for debugging purposes if (ASSOCIATED(CS)) then @@ -142,10 +143,16 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) + call get_param(param_file, mdl, "HBD_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for horizontal boundary diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) ! GMM, TODO: add HBD params to control optional arguments in initialize_remapping. - call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction=.false., check_remapping=.false.) + call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + check_reconstruction=.false., check_remapping=.false., & + h_neglect=CS%H_subroundoff, h_neglect_edge=CS%H_subroundoff) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & @@ -733,10 +740,8 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ allocate(khtr_ul_z(nk), source=0.0) ! remap tracer to dz_top - call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & - CS%H_subroundoff, CS%H_subroundoff) - call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:), & - CS%H_subroundoff, CS%H_subroundoff) + call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:)) + call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:)) ! thicknesses at velocity points & khtr_u at layer centers do k = 1,ke @@ -747,8 +752,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ enddo ! remap khtr_ul to khtr_ul_z - call remapping_core_h(CS%remap_cs, ke, h_vel(:), khtr_ul(:), nk, dz_top(:), khtr_ul_z(:), & - CS%H_subroundoff, CS%H_subroundoff) + call remapping_core_h(CS%remap_cs, ke, h_vel(:), khtr_ul(:), nk, dz_top(:), khtr_ul_z(:)) ! Calculate vertical indices containing the boundary layer in dz_top call boundary_k_range(boundary, nk, dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) @@ -849,14 +853,16 @@ logical function near_boundary_unit_tests( verbose ) allocate(CS) ! fill required fields in CS CS%linear=.false. - call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true. ,& - check_reconstruction=.true., check_remapping=.true.) - call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) CS%H_subroundoff = 1.0E-20 CS%debug=.false. CS%limiter=.false. CS%limiter_remap=.false. CS%hbd_nk = 2 + (2*2) + call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.true., & ! ### see fail below when using fixed remapping alg. + check_reconstruction=.true., check_remapping=.true., & + h_neglect=CS%H_subroundoff, h_neglect_edge=CS%H_subroundoff) + call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) allocate(CS%hbd_grd_u(1,1,CS%hbd_nk), source=0.0) allocate(CS%hbd_u_kmax(1,1), source=0) near_boundary_unit_tests = .false. @@ -1040,6 +1046,7 @@ logical function near_boundary_unit_tests( verbose ) call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) + ! ### This test fails when om4_remap_via_sub_cells=.false. near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-4.0/) ) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 402a008244..1aaf7409d2 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -57,8 +57,8 @@ module MOM_neutral_diffusion logical :: tapering = .false. !< If true, neutral diffusion linearly decays towards zero within a !! transition zone defined using boundary layer depths. Only available when !! interior_only=true. - logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure - !! as the vertical structure of tracer diffusivity. + logical :: KhTh_use_vert_struct !< If true, uses vertical structure + !! for tracer diffusivity. logical :: use_unmasked_transport_bug !< If true, use an older form for the accumulation of !! neutral-diffusion transports that were unmasked, as used prior to Jan 2018. real, allocatable, dimension(:,:) :: hbl !< Boundary layer depth [H ~> m or kg m-2] @@ -67,7 +67,7 @@ module MOM_neutral_diffusion !! at cell interfaces [nondim] real, allocatable, dimension(:) :: coeff_r !< Non-dimensional coefficient in the right column, !! at cell interfaces [nondim] - ! Array used when KhTh_use_ebt_struct is true + ! Array used when KhTh_use_vert_struct is true real, allocatable, dimension(:,:,:) :: Coef_h !< Coef_x and Coef_y averaged at t-points [L2 ~> m2] ! Positions of neutral surfaces in both the u, v directions real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point [nondim] @@ -152,6 +152,8 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, logical :: debug ! If true, write verbose checksums for debugging purposes. logical :: boundary_extrap ! Indicate whether high-order boundary !! extrapolation should be used within boundary cells. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + logical :: KhTh_use_ebt_struct, KhTh_use_sqg_struct if (associated(CS)) then call MOM_error(FATAL, "neutral_diffusion_init called with associated control structure.") @@ -196,10 +198,14 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "a transition zone defined using boundary layer depths. "//& "Only applicable when NDIFF_INTERIOR_ONLY=True", default=.false.) endif - call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", KhTh_use_ebt_struct, & "If true, uses the equivalent barotropic structure "//& "as the vertical structure of the tracer diffusivity.",& default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "KHTR_USE_SQG_STRUCT", KhTh_use_sqg_struct, & + "If true, uses the surface geostrophic structure "//& + "as the vertical structure of the tracer diffusivity.",& + default=.false.,do_not_log=.true.) call get_param(param_file, mdl, "NDIFF_USE_UNMASKED_TRANSPORT_BUG", CS%use_unmasked_transport_bug, & "If true, use an older form for the accumulation of neutral-diffusion "//& "transports that were unmasked, as used prior to Jan 2018. This is not "//& @@ -232,8 +238,13 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) + call get_param(param_file, mdl, "NDIFF_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for neutral diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%remap_answer_date ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "NEUTRAL_POS_METHOD", CS%neutral_pos_method, & @@ -290,7 +301,8 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, endif endif - if (CS%KhTh_use_ebt_struct) & + CS%KhTh_use_vert_struct = KhTh_use_ebt_struct .or. KhTh_use_sqg_struct + if (CS%KhTh_use_vert_struct) & allocate(CS%Coef_h(G%isd:G%ied,G%jsd:G%jed,SZK_(GV)+1), source=0.) ! Store a rescaling factor for use in diagnostic messages. @@ -618,11 +630,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer in units that vary between a ! thickness times a concentration ([C H ~> degC m or degC kg m-2] for temperature) or a ! volume or mass times a concentration ([C H L2 ~> degC m3 or degC kg] for temperature), - ! depending on the setting of CS%KhTh_use_ebt_struct. + ! depending on the setting of CS%KhTh_use_vert_struct. real, dimension(SZI_(G),SZJB_(G),CS%nsurf-1) :: vFlx ! Meridional flux of tracer in units that vary between a ! thickness times a concentration ([C H ~> degC m or degC kg m-2] for temperature) or a ! volume or mass times a concentration ([C H L2 ~> degC m3 or degC kg] for temperature), - ! depending on the setting of CS%KhTh_use_ebt_struct. + ! depending on the setting of CS%KhTh_use_vert_struct. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency ! tendency array for diagnostics ! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1] ! For temperature these units are @@ -667,7 +679,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) endif endif - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then ! Compute Coef at h points CS%Coef_h(:,:,:) = 0. do j = G%jsc,G%jec ; do i = G%isc,G%iec @@ -700,7 +712,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) vFlx(:,:,:) = 0. ! x-flux - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then if (CS%tapering) then do j = G%jsc,G%jec ; do I = G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then @@ -764,7 +776,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) endif ! y-flux - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then if (CS%tapering) then do J = G%jsc-1,G%jec ; do i = G%isc,G%iec if (G%mask2dCv(i,J)>0.) then @@ -831,7 +843,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) ! Update the tracer concentration from divergence of neutral diffusive flux components, noting ! that uFlx and vFlx use an unexpected sign convention. - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then do j = G%jsc,G%jec ; do i = G%isc,G%iec if (G%mask2dT(i,j)>0.) then if (CS%ndiff_answer_date <= 20240330) then @@ -934,7 +946,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) ! Note sign corresponds to downgradient flux convention. if (tracer%id_dfx_2d > 0) then - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then do j = G%jsc,G%jec ; do I = G%isc-1,G%iec trans_x_2d(I,j) = 0. if (G%mask2dCu(I,j)>0.) then @@ -963,7 +975,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) ! Note sign corresponds to downgradient flux convention. if (tracer%id_dfy_2d > 0) then - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then do J = G%jsc-1,G%jec ; do i = G%isc,G%iec trans_y_2d(i,J) = 0. if (G%mask2dCv(i,J)>0.) then @@ -1568,34 +1580,39 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) character(len=120) :: mesg - if (Ppos < Pneg) then - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! PposdRhoPos) then - write(stderr,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos - write(mesg,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=', dRhoNeg, Pneg, dRhoPos, Ppos - call MOM_error(WARNING, 'interpolate_for_nondim_position: '//trim(mesg)) - elseif (dRhoNeg>dRhoPos) then !### Does this duplicated test belong here? - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos') - endif - if (Ppos<=Pneg) then ! Handle vanished or inverted layers - interpolate_for_nondim_position = 0.5 - elseif ( dRhoPos - dRhoNeg > 0. ) then - interpolate_for_nondim_position = min( 1., max( 0., -dRhoNeg / ( dRhoPos - dRhoNeg ) ) ) - elseif ( dRhoPos - dRhoNeg == 0) then - if (dRhoNeg>0.) then - interpolate_for_nondim_position = 0. - elseif (dRhoNeg<0.) then - interpolate_for_nondim_position = 1. - else ! dRhoPos = dRhoNeg = 0 + if ((Ppos > Pneg) .and. (dRhoPos - dRhoNeg >= 0. )) then + if ( dRhoPos - dRhoNeg > 0. ) then + interpolate_for_nondim_position = min( 1., max( 0., -dRhoNeg / ( dRhoPos - dRhoNeg ) ) ) + elseif (dRhoPos - dRhoNeg == 0) then + if (dRhoNeg > 0.) then + interpolate_for_nondim_position = 0. + elseif (dRhoNeg < 0.) then + interpolate_for_nondim_position = 1. + else ! dRhoPos = dRhoNeg = 0 + interpolate_for_nondim_position = 0.5 + endif + else ! dRhoPos - dRhoNeg < 0 interpolate_for_nondim_position = 0.5 endif - else ! dRhoPos - dRhoNeg < 0 + elseif (Ppos == Pneg) then ! Handle vanished or inverted layers interpolate_for_nondim_position = 0.5 + else ! ((Ppos < Pneg) .or. (dRhoNeg > dRhoPos) ) + ! Error handling for problematic cases. It is expected that this should never occur. + write(mesg,*) 'dRhoNeg, Pneg, dRhoPos, Ppos', dRhoNeg, Pneg, dRhoPos, Ppos + call MOM_error(WARNING, 'interpolate_for_nondim_position: '//trim(mesg)) + ! write(stderr,*) trim(mesg) + if ((Ppos < Pneg) .and. (dRhoNeg > dRhoPos)) then + mesg = '(Ppos < Pneg) and (dRhoNeg > dRhoPos)' + elseif (Ppos < Pneg) then + mesg = 'Ppos < Pneg' + elseif (dRhoNeg > dRhoPos) then + mesg = trim(mesg)//'; dRhoNeg > dRhoPos' + else ! This should never happen. + mesg = 'Unexpected failure.' + endif + call MOM_error(FATAL, 'interpolate_for_nondim_position: '//trim(mesg)) endif - if ( interpolate_for_nondim_position < 0. ) & - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg') - if ( interpolate_for_nondim_position > 1. ) & - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos') + end function interpolate_for_nondim_position !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index b31ebba7c8..f772e0bc8a 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -306,8 +306,8 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C enddo ; enddo ; enddo if (CS%debug) then - call hchksum(h_pre, "h_pre before transport", G%HI, scale=GV%H_to_MKS) - call uvchksum("[uv]htr_sub before transport", uhtr_sub, vhtr_sub, G%HI, scale=HL2_to_kg_scale) + call hchksum(h_pre, "h_pre before transport", G%HI, unscale=GV%H_to_MKS) + call uvchksum("[uv]htr_sub before transport", uhtr_sub, vhtr_sub, G%HI, unscale=HL2_to_kg_scale) endif tot_residual = remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) if (CS%print_adv_offline) then @@ -325,8 +325,8 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C enddo ; enddo ; enddo if (CS%debug) then - call hchksum(h_vol, "h_vol before advect", G%HI, scale=HL2_to_kg_scale) - call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI, scale=HL2_to_kg_scale) + call hchksum(h_vol, "h_vol before advect", G%HI, unscale=HL2_to_kg_scale) + call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI, unscale=HL2_to_kg_scale) write(debug_msg, '(A,I4.4)') 'Before advect ', iter call MOM_tracer_chkinv(debug_msg, G, GV, h_pre, CS%tracer_reg) endif @@ -347,7 +347,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C ! Do ALE remapping/regridding to allow for more advection to occur in the next iteration call pass_var(h_new,G%Domain) if (CS%debug) then - call hchksum(h_new,"h_new before ALE", G%HI, scale=GV%H_to_MKS) + call hchksum(h_new,"h_new before ALE", G%HI, unscale=GV%H_to_MKS) write(debug_msg, '(A,I4.4)') 'Before ALE ', iter call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg) endif @@ -373,7 +373,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C call cpu_clock_end(id_clock_ALE) if (CS%debug) then - call hchksum(h_new, "h_new after ALE", G%HI, scale=GV%H_to_MKS) + call hchksum(h_new, "h_new after ALE", G%HI, unscale=GV%H_to_MKS) write(debug_msg, '(A,I4.4)') 'After ALE ', iter call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg) endif @@ -415,8 +415,8 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C call pass_vector(uhtr, vhtr, G%Domain) if (CS%debug) then - call hchksum(h_pre, "h after offline_advection_ale", G%HI, scale=GV%H_to_MKS) - call uvchksum("[uv]htr after offline_advection_ale", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + call hchksum(h_pre, "h after offline_advection_ale", G%HI, unscale=GV%H_to_MKS) + call uvchksum("[uv]htr after offline_advection_ale", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) call MOM_tracer_chkinv("After offline_advection_ale", G, GV, h_pre, CS%tracer_reg) endif @@ -501,7 +501,7 @@ subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, conve if (CS%debug) then call MOM_tracer_chksum("Before upwards redistribute ", CS%tracer_Reg, G) - call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) endif if (x_before_y) then @@ -542,7 +542,7 @@ subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, conve if (CS%debug) then call MOM_tracer_chksum("Before barotropic redistribute ", CS%tracer_Reg, G) - call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) endif if (x_before_y) then @@ -602,8 +602,8 @@ subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, conve if (CS%id_vhr>0) call post_data(CS%id_vhr, vhtr, CS%diag) if (CS%debug) then - call hchksum(h_pre, "h_pre after redistribute", G%HI, scale=GV%H_to_MKS) - call uvchksum("uhtr after redistribute", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + call hchksum(h_pre, "h_pre after redistribute", G%HI, unscale=GV%H_to_MKS) + call uvchksum("uhtr after redistribute", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) call MOM_tracer_chkinv("after redistribute ", G, GV, h_new, CS%tracer_Reg) endif @@ -685,9 +685,9 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p call MOM_mesg("Applying tracer source, sinks, and vertical mixing") if (CS%debug) then - call hchksum(h_pre, "h_pre before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) - call hchksum(eatr, "eatr before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) - call hchksum(ebtr, "ebtr before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(h_pre, "h_pre before offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(eatr, "eatr before offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(ebtr, "ebtr before offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("Before offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) endif @@ -751,9 +751,9 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p endif if (CS%debug) then - call hchksum(h_pre, "h_pre after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) - call hchksum(eatr, "eatr after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) - call hchksum(ebtr, "ebtr after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(h_pre, "h_pre after offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(eatr, "eatr after offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(ebtr, "ebtr after offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("After offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) endif @@ -794,7 +794,7 @@ subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) enddo ; enddo if (CS%debug) then - call hchksum(h, "h before fluxes into ocean", G%HI, scale=GV%H_to_MKS) + call hchksum(h, "h before fluxes into ocean", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("Before fluxes into ocean", G, GV, h, CS%tracer_reg) endif do m = 1,CS%tracer_reg%ntr @@ -804,7 +804,7 @@ subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt=update_h) enddo if (CS%debug) then - call hchksum(h, "h after fluxes into ocean", G%HI, scale=GV%H_to_MKS) + call hchksum(h, "h after fluxes into ocean", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("After fluxes into ocean", G, GV, h, CS%tracer_reg) endif @@ -833,7 +833,7 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) call MOM_error(WARNING, "Negative freshwater fluxes with non-zero tracer concentration not supported yet") if (CS%debug) then - call hchksum(h, "h before fluxes out of ocean", G%HI, scale=GV%H_to_MKS) + call hchksum(h, "h before fluxes out of ocean", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg) endif do m = 1, CS%tracer_reg%ntr @@ -843,7 +843,7 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt = update_h) enddo if (CS%debug) then - call hchksum(h, "h after fluxes out of ocean", G%HI, scale=GV%H_to_MKS) + call hchksum(h, "h after fluxes out of ocean", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg) endif @@ -1041,10 +1041,10 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) if (CS%debug) then call uvchksum("[uv]htr before update_offline_fields", CS%uhtr, CS%vhtr, G%HI, & - scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(CS%h_end, "h_end before update_offline_fields", G%HI, scale=GV%H_to_MKS) - call hchksum(CS%tv%T, "Temp before update_offline_fields", G%HI, scale=US%C_to_degC) - call hchksum(CS%tv%S, "Salt before update_offline_fields", G%HI, scale=US%S_to_ppt) + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%h_end, "h_end before update_offline_fields", G%HI, unscale=GV%H_to_MKS) + call hchksum(CS%tv%T, "Temp before update_offline_fields", G%HI, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt before update_offline_fields", G%HI, unscale=US%S_to_ppt) endif ! Store a copy of the layer thicknesses before ALE regrid/remap @@ -1063,9 +1063,9 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) endif if (CS%debug) then call uvchksum("[uv]h after update offline from files and arrays", CS%uhtr, CS%vhtr, G%HI, & - scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(CS%tv%T, "Temp after update offline from files and arrays", G%HI, scale=US%C_to_degC) - call hchksum(CS%tv%S, "Salt after update offline from files and arrays", G%HI, scale=US%S_to_ppt) + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%tv%T, "Temp after update offline from files and arrays", G%HI, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt after update offline from files and arrays", G%HI, unscale=US%S_to_ppt) endif ! If using an ALE-dependent vertical coordinate, fields will need to be remapped @@ -1083,8 +1083,8 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) if (CS%id_h_regrid>0) call post_data(CS%id_h_regrid, h, CS%diag) if (CS%debug) then call uvchksum("[uv]htr after ALE regridding/remapping of inputs", CS%uhtr, CS%vhtr, G%HI, & - scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(h_start,"h_start after ALE regridding/remapping of inputs", G%HI, scale=GV%H_to_MKS) + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(h_start,"h_start after ALE regridding/remapping of inputs", G%HI, unscale=GV%H_to_MKS) endif endif @@ -1131,10 +1131,10 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) if (CS%debug) then call uvchksum("[uv]htr after update_offline_fields", CS%uhtr, CS%vhtr, G%HI, & - scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(CS%h_end, "h_end after update_offline_fields", G%HI, scale=GV%H_to_MKS) - call hchksum(CS%tv%T, "Temp after update_offline_fields", G%HI, scale=US%C_to_degC) - call hchksum(CS%tv%S, "Salt after update_offline_fields", G%HI, scale=US%S_to_ppt) + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%h_end, "h_end after update_offline_fields", G%HI, unscale=GV%H_to_MKS) + call hchksum(CS%tv%T, "Temp after update_offline_fields", G%HI, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt after update_offline_fields", G%HI, unscale=US%S_to_ppt) endif call callTree_leave("update_offline_fields") diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 2cf0ba1efe..c471b61717 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -464,11 +464,6 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & end subroutine read_Z_edges -!### `find_overlap` and `find_limited_slope` were previously part of -! MOM_diag_to_Z.F90, and are nearly identical to `find_overlap` in -! `midas_vertmap.F90` with some slight differences. We keep it here for -! reproducibility, but the two should be merged at some point - !> Determines the layers bounded by interfaces e that overlap !! with the depth range between Z_top and Z_bot, and the fractional weights !! of each layer. It also calculates the normalized relative depths of the range @@ -620,15 +615,13 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "determine_temperature" ! This subroutine's name. - logical :: adjust_salt, fit_together + logical :: domore(SZK_(GV)) ! Records which layers need additional iterations + logical :: adjust_salt, fit_together, convergence_bug, do_any integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - ! ### The algorithms of determine_temperature subroutine needs to be reexamined. - - call log_version(PF, mdl, version, "") ! We should switch the default to the newer method which simultaneously adjusts @@ -638,7 +631,13 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, "based on the ratio of the thermal and haline coefficients. Otherwise try to "//& "match the density by only adjusting temperatures within a maximum range before "//& "revising estimates of the salinity.", default=.false., do_not_log=just_read) - ! These hard coded parameters need to be set properly. + call get_param(PF, mdl, "DETERMINE_TEMP_CONVERGENCE_BUG", convergence_bug, & + "If true, use layout-dependent tests on the changes in temperature and salinity "//& + "to determine when the iterations have converged when DETERMINE_TEMP_ADJUST_T_AND_S "//& + "is false. For realistic equations of state and the default values of the "//& + "various tolerances, this bug does not impact the solutions.", & + default=.true., do_not_log=just_read) !### Change the default to false. + call get_param(PF, mdl, "DETERMINE_TEMP_T_MIN", T_min, & "The minimum temperature that can be found by determine_temperature.", & units="degC", default=-2.0, scale=US%degC_to_C, do_not_log=just_read) @@ -653,10 +652,12 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, units="ppt", default=65.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(PF, mdl, "DETERMINE_TEMP_T_TOLERANCE", tol_T, & "The convergence tolerance for temperature in determine_temperature.", & - units="degC", default=1.0e-4, scale=US%degC_to_C, do_not_log=just_read) + units="degC", default=1.0e-4, scale=US%degC_to_C, & + do_not_log=just_read.or.(.not.convergence_bug)) call get_param(PF, mdl, "DETERMINE_TEMP_S_TOLERANCE", tol_S, & "The convergence tolerance for temperature in determine_temperature.", & - units="ppt", default=1.0e-4, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=1.0e-4, scale=US%ppt_to_S, & + do_not_log=just_read.or.(.not.convergence_bug)) call get_param(PF, mdl, "DETERMINE_TEMP_RHO_TOLERANCE", tol_rho, & "The convergence tolerance for density in determine_temperature.", & units="kg m-3", default=1.0e-4, scale=US%kg_m3_to_R, do_not_log=just_read) @@ -689,49 +690,69 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, T(:,:) = temp(:,j,:) S(:,:) = salt(:,j,:) dT(:,:) = 0.0 + domore(:) = .true. adjust_salt = .true. iter_loop: do itt = 1,niter - do k=1,nz + do k=k_start,nz ; if (domore(k)) then + domore(k) = .false. call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & EOS, EOSdom ) - enddo - do k=k_start,nz ; do i=is,ie -! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln) then - if (abs(rho(i,k)-R_tgt(k))>tol_rho) then - if (.not.fit_together) then - dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - else - I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) - dS(i,k) = (R_tgt(k)-rho(i,k)) * drho_dS(i,k) * I_denom - dT(i,k) = (R_tgt(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom + do i=is,ie +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln) then + if (abs(rho(i,k)-R_tgt(k))>tol_rho) then + domore(k) = .true. + if (.not.fit_together) then + dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + else + I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) + dS(i,k) = (R_tgt(k)-rho(i,k)) * drho_dS(i,k) * I_denom + dT(i,k) = (R_tgt(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + endif endif + enddo + endif ; enddo + if (convergence_bug) then + ! If this test does anything, it is layout-dependent. + if (maxval(abs(dT)) < tol_T) then + adjust_salt = .false. + exit iter_loop endif - enddo ; enddo - if (maxval(abs(dT)) < tol_T) then - adjust_salt = .false. - exit iter_loop endif + + do_any = .false. + do k=k_start,nz ; if (domore(k)) do_any = .true. ; enddo + if (.not.do_any) exit iter_loop ! Further iterations will not change anything. enddo iter_loop if (adjust_salt .and. .not.fit_together) then ; do itt = 1,niter - do k=1,nz + do k=k_start,nz ; if (domore(k)) then + domore(k) = .false. call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & EOS, EOSdom ) - enddo - do k=k_start,nz ; do i=is,ie -! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln ) then - if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then - dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) - endif - enddo ; enddo - if (maxval(abs(dS)) < tol_S) exit + do i=is,ie +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln ) then + if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then + dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + domore(k) = .true. + endif + enddo + endif ; enddo + + if (convergence_bug) then + ! If this test does anything, it is layout-dependent. + if (maxval(abs(dS)) < tol_S) exit + endif + + do_any = .false. + do k=k_start,nz ; if (domore(k)) do_any = .true. ; enddo + if (.not.do_any) exit ! Further iterations will not change anything enddo ; endif temp(:,j,:) = T(:,:) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 7118fdd401..0e129b2d03 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -1133,14 +1133,16 @@ subroutine tracer_advect_init(Time, G, US, param_file, diag, CS) "Unknown TRACER_ADVECTION_SCHEME = "//trim(mesg)) end select - if (CS%useHuynh) then - call get_param(param_file, mdl, "USE_HUYNH_STENCIL_BUG", & + if (CS%usePPM) then + if (CS%useHuynh) then + call get_param(param_file, mdl, "USE_HUYNH_STENCIL_BUG", & CS%useHuynhStencilBug, & desc="If true, use a stencil width of 2 in PPM:H3 tracer advection. " & // "This is incorrect and will produce regressions in certain " & // "configurations, but may be required to reproduce results in " & // "legacy simulations.", & default=.false.) + endif endif id_clock_advect = cpu_clock_id('(Ocean advect tracer)', grain=CLOCK_MODULE) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index ca85fc234f..2f1ebd2635 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -746,9 +746,10 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock call store_stocks("MOM_generic_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) nn=ns_tot-ns+1 - nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & - xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& - G, CS%MOM_generic_tracer_CSp,names, units) + if (present(got_min_max) .and. present(global_min) .and. present(global_max)) & + nn = MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & + G, CS%MOM_generic_tracer_CSp, names, units, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) endif if (CS%use_pseudo_salt_tracer) then diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 8cab315db9..3511b88f39 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -52,7 +52,7 @@ module MOM_tracer_hor_diff real :: max_diff_CFL !< If positive, locally limit the along-isopycnal !! tracer diffusivity to keep the diffusive CFL !! locally at or below this value [nondim]. - logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure + logical :: KhTr_use_vert_struct !< If true, uses the equivalent barotropic structure !! as the vertical structure of tracer diffusivity. logical :: Diffuse_ML_interior !< If true, diffuse along isopycnals between !! the mixed layer and the interior. @@ -218,6 +218,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ use_VarMix = VarMix%use_variable_mixing Resoln_scaled = VarMix%Resoln_scaled_KhTr use_Eady = CS%KhTr_Slope_Cff > 0. + CS%KhTr_use_vert_struct = allocated(VarMix%khtr_struct) endif call cpu_clock_begin(id_clock_pass) @@ -422,18 +423,18 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ enddo enddo enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_vert_struct) then do K=2,nz+1 do J=js-1,je do i=is,ie - Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) enddo enddo enddo do k=2,nz+1 do j=js,je do I=is-1,ie - Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) enddo enddo enddo @@ -478,18 +479,18 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ enddo enddo enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_vert_struct) then do K=2,nz+1 do J=js-1,je do i=is,ie - Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) enddo enddo enddo do k=2,nz+1 do j=js,je do I=is-1,ie - Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) enddo enddo enddo @@ -605,11 +606,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ do j=js,je ; do I=is-1,ie Kh_u(I,j,:) = G%mask2dCu(I,j)*Kh_u(I,j,1) enddo ; enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_vert_struct) then do K=2,nz+1 do j=js,je do I=is-1,ie - Kh_u(I,j,K) = Kh_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + Kh_u(I,j,K) = Kh_u(I,j,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) enddo enddo enddo @@ -621,11 +622,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ do J=js-1,je ; do i=is,ie Kh_v(i,J,:) = G%mask2dCv(i,J)*Kh_v(i,J,1) enddo ; enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_vert_struct) then do K=2,nz+1 do J=js-1,je do i=is,ie - Kh_v(i,J,K) = Kh_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + Kh_v(i,J,K) = Kh_v(i,J,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) enddo enddo enddo @@ -647,9 +648,9 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) Kh_h(i,j,:) = normalize*G%mask2dT(i,j)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & (Kh_v(i,J-1,1)+Kh_v(i,J,1))) - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_vert_struct) then do K=2,nz+1 - Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%ebt_struct(i,j,k-1)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & + Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%khtr_struct(i,j,k-1)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & (Kh_v(i,J-1,1)+Kh_v(i,J,1))) enddo endif @@ -660,7 +661,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ if (CS%debug) then call uvchksum("After tracer diffusion khdt_[xy]", khdt_x, khdt_y, & - G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & + G%HI, haloshift=0, symmetric=.true., unscale=US%L_to_m**2, & scalar_pair=.true.) endif @@ -1630,10 +1631,10 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_file, mdl, "KHTR", CS%KhTr, & "The background along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) - call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & - "If true, uses the equivalent barotropic structure "//& - "as the vertical structure of the tracer diffusivity.",& - default=.false.) +! call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & +! "If true, uses the equivalent barotropic structure "//& +! "as the vertical structure of the tracer diffusivity.",& +! default=.false.) call get_param(param_file, mdl, "KHTR_SLOPE_CFF", CS%KhTr_Slope_Cff, & "The scaling coefficient for along-isopycnal tracer "//& "diffusivity using a shear-based (Visbeck-like) "//& diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 0a5a8d4efd..835b93bb82 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -760,7 +760,7 @@ subroutine tracer_array_chksum(mesg, Tr, ntr, G) integer :: m do m=1,ntr - call hchksum(Tr(m)%t, mesg//trim(Tr(m)%name), G%HI, scale=Tr(m)%conc_scale) + call hchksum(Tr(m)%t, mesg//trim(Tr(m)%name), G%HI, unscale=Tr(m)%conc_scale) enddo end subroutine tracer_array_chksum @@ -776,7 +776,7 @@ subroutine tracer_Reg_chksum(mesg, Reg, G) if (.not.associated(Reg)) return do m=1,Reg%ntr - call hchksum(Reg%Tr(m)%t, mesg//trim(Reg%Tr(m)%name), G%HI, scale=Reg%Tr(m)%conc_scale) + call hchksum(Reg%Tr(m)%t, mesg//trim(Reg%Tr(m)%name), G%HI, unscale=Reg%Tr(m)%conc_scale) enddo end subroutine tracer_Reg_chksum diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 2684901b37..dbf9180948 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -329,7 +329,7 @@ subroutine advection_test_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index b8ed0632a2..0698d7f9cc 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -340,7 +340,7 @@ subroutine boundary_impulse_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index ff2199fc80..2cc4654691 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -395,7 +395,7 @@ subroutine dye_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 4323479823..147c48eebd 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -342,8 +342,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (CS%use_real_BL_depth .and. .not. present(Hbl)) then - call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, & - but no valid boundary layer scheme was found") + call MOM_error(FATAL, "Attempting to use real boundary layer depth for ideal age tracers, " & + // "but no valid boundary layer scheme was found") endif if (CS%use_real_BL_depth .and. present(Hbl)) then @@ -559,7 +559,7 @@ subroutine ideal_age_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 22310b5802..1260711347 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -466,7 +466,7 @@ subroutine oil_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index ade36bad19..b737dba5b7 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -214,7 +214,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G if (.not.associated(CS%ps)) return if (debug) then - call hchksum(tv%S,"salt pre pseudo-salt vertdiff", G%HI, scale=US%S_to_ppt) + call hchksum(tv%S,"salt pre pseudo-salt vertdiff", G%HI, unscale=US%S_to_ppt) call hchksum(CS%ps,"pseudo_salt pre pseudo-salt vertdiff", G%HI) endif @@ -267,7 +267,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G endif if (debug) then - call hchksum(tv%S, "salt post pseudo-salt vertdiff", G%HI, scale=US%S_to_ppt) + call hchksum(tv%S, "salt post pseudo-salt vertdiff", G%HI, unscale=US%S_to_ppt) call hchksum(CS%ps, "pseudo_salt post pseudo-salt vertdiff", G%HI) endif diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index fa9b978f9c..ff2812b8ee 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -427,7 +427,7 @@ subroutine USER_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index d37b1d70ae..b96b363e3a 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -13,10 +13,9 @@ module Idealized_hurricane ! The T/S initializations have been removed since they are redundant ! w/ T/S initializations in CVMix_tests (which should be moved ! into the main state_initialization to their utility -! for multiple example cases).. +! for multiple example cases). ! To do ! 1. Remove the legacy SCM_idealized_hurricane_wind_forcing code -! 2. Make the hurricane-to-background wind transition a runtime parameter ! use MOM_error_handler, only : MOM_error, FATAL @@ -49,6 +48,10 @@ module Idealized_hurricane real :: pressure_ambient !< Pressure at surface of ambient air [R L2 T-2 ~> Pa] real :: pressure_central !< Pressure at surface at hurricane center [R L2 T-2 ~> Pa] real :: rad_max_wind !< Radius of maximum winds [L ~> m] + real :: rad_edge !< Radius of the edge of the hurricane, normalized by + !! the radius of maximum winds [nondim] + real :: rad_ambient !< Radius at which the winds are at their ambient background values, + !! normalized by the radius of maximum winds [nondim] real :: max_windspeed !< Maximum wind speeds [L T-1 ~> m s-1] real :: hurr_translation_spd !< Hurricane translation speed [L T-1 ~> m s-1] real :: hurr_translation_dir !< Hurricane translation direction [radians] @@ -60,34 +63,60 @@ module Idealized_hurricane real :: Hurr_cen_X0 !< The initial x position of the hurricane !! This experiment is conducted in a Cartesian !! grid and this is assumed to be in meters [L ~> m] - real :: Holland_A !< Parameter 'A' from the Holland formula [nondim] real :: Holland_B !< Parameter 'B' from the Holland formula [nondim] - real :: Holland_AxBxDP !< 'A' x 'B' x (Pressure Ambient-Pressure central) - !! for the Holland prorfile calculation [R L2 T-2 ~> Pa] logical :: relative_tau !< A logical to take difference between wind !! and surface currents to compute the stress integer :: answer_date !< The vintage of the expressions in the idealized hurricane !! test case. Values below 20190101 recover the answers !! from the end of 2018, while higher values use expressions !! that are rescalable and respect rotational symmetry. + ! Parameters used in a simple wind-speed dependent expression for C_drag + real :: Cd_calm !< The drag coefficient with weak relative winds [nondim] + real :: calm_speed !< The relative wind speed below which the drag coefficient takes its + !! calm value [L T-1 ~> m s-1] + real :: Cd_windy !< The drag coefficient with strong relative winds [nondim] + real :: windy_speed !< The relative wind speed below which the drag coefficient takes its + !! windy value [L T-1 ~> m s-1] + real :: dCd_dU10 !< The partial derivative of the drag coefficient times 1000 with the 10 m + !! wind speed for intermediate wind speeds [T L-1 ~> s m-1] + real :: Cd_intercept !< The zero-wind intercept times 1000 of the linear fit for the drag + !! coefficient for the intermediate speeds where there is a linear + !! dependence on the 10 m wind speed [nondim] + + ! Parameters used to set the inflow angle as a function of radius and maximum wind speed + real :: A0_0 !< The zero-radius, zero-speed intercept of the axisymmetric inflow angle [degrees] + real :: A0_Rnorm !< The normalized radius dependence of the axisymmetric inflow angle [degrees] + real :: A0_speed !< The maximum wind speed dependence of the axisymmetric inflow angle + !! [degrees T L-1 ~> degrees s m-1] + real :: A1_0 !< The zero-radius, zero-speed intercept of the normalized inflow angle + !! asymmetry [degrees] + real :: A1_Rnorm !< The normalized radius dependence of the normalized inflow angle asymmetry [degrees] + real :: A1_speed !< The translation speed dependence of the normalized inflow angle asymmetry + !! [degrees T L-1 ~> degrees s m-1] + real :: P1_0 !< The zero-radius, zero-speed intercept of the angle difference between the + !! translation direction and the inflow direction [degrees] + real :: P1_Rnorm !< The normalized radius dependence of the angle difference between the + !! translation direction and the inflow direction [degrees] + real :: P1_speed !< The translation speed dependence of the angle difference between the + !! translation direction and the inflow direction [degrees T L-1 ~> degrees s m-1] ! Parameters used if in SCM (single column model) mode - logical :: SCM_mode !< If true this being used in Single Column Model mode - logical :: BR_BENCH !< A "benchmark" configuration (which is meant to - !! provide identical wind to reproduce a previous - !! experiment, where that wind formula contained - !! an error) + logical :: SCM_mode !< If true this being used in Single Column Model mode + logical :: edge_taper_bug !< If true and SCM_mode is true, use a bug that does all of the tapering + !! and inflow angle calculations for radii between RAD_EDGE and RAD_AMBIENT + !! as though they were at RAD_EDGE. + real :: f_column !< Coriolis parameter used in the single column mode idealized + !! hurricane wind profile [T-1 ~> s-1] + logical :: BR_Bench !< A "benchmark" configuration (which is meant to + !! provide identical wind to reproduce a previous + !! experiment, where that wind formula contained an error) real :: dy_from_center !< (Fixed) distance in y from storm center path [L ~> m] - ! Par - real :: PI !< Mathematical constant - real :: Deg2Rad !< Mathematical constant + real :: pi !< The circumference of a circle divided by its diameter [nondim] + real :: Deg2Rad !< The conversion factor from degrees to radians [radian degree-1] end type -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "idealized_hurricane" !< This module's name. contains @@ -102,8 +131,11 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) ! Local variables real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] - real :: C ! A temporary variable [nondim] + real :: C ! A temporary variable in units of the square root of a specific volume [sqrt(m3 kg-1)] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: continuous_Cd ! If true, use a continuous form for the simple drag coefficient as a + ! function of wind speed with the idealized hurricane. When this is false, the + ! linear shape for the mid-range wind speeds is specified separately. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -132,16 +164,22 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) call get_param(param_file, mdl, "IDL_HURR_CENTRAL_PRESSURE", CS%pressure_central, & "Central pressure used in the idealized hurricane wind profile.", & units='Pa', default=96800., scale=US%Pa_to_RL2_T2) - call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", & - CS%rad_max_wind, "Radius of maximum winds used in the "//& - "idealized hurricane wind profile.", & + call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", CS%rad_max_wind, & + "Radius of maximum winds used in the idealized hurricane wind profile.", & units='m', default=50.e3, scale=US%m_to_L) + call get_param(param_file, mdl, "IDL_HURR_RAD_EDGE", CS%rad_edge, & + "Radius of the edge of the hurricane, normalized by the radius of maximum winds.", & + units='nondim', default=10.0) + call get_param(param_file, mdl, "IDL_HURR_RAD_AMBIENT", CS%rad_ambient, & + "Radius at which the winds are at their ambient background values, "//& + "normalized by the radius of maximum winds.", & + units='nondim', default=CS%rad_edge+2.0) call get_param(param_file, mdl, "IDL_HURR_MAX_WIND", CS%max_windspeed, & - "Maximum wind speed used in the idealized hurricane"// & - "wind profile.", units='m/s', default=65., scale=US%m_s_to_L_T) + "Maximum wind speed used in the idealized hurricane wind profile.", & + units='m/s', default=65., scale=US%m_s_to_L_T) call get_param(param_file, mdl, "IDL_HURR_TRAN_SPEED", CS%hurr_translation_spd, & - "Translation speed of hurricane used in the idealized "//& - "hurricane wind profile.", units='m/s', default=5.0, scale=US%m_s_to_L_T) + "Translation speed of hurricane used in the idealized hurricane wind profile.", & + units='m/s', default=5.0, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "IDL_HURR_TRAN_DIR", CS%hurr_translation_dir, & "Translation direction (towards) of hurricane used in the "//& "idealized hurricane wind profile.", & @@ -156,17 +194,67 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "Current relative stress switch used in the idealized hurricane wind profile.", & default=.false.) + call get_param(param_file, mdl, "IDL_HURR_AXI_INFLOW_0", CS%A0_0, & + "The zero-radius asymmetry, zero-speed intercept of the axisymmetric inflow "//& + "angle for the parametric idealized hurricane.", & + default=-14.33, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_AXI_INFLOW_RNORM", CS%A0_Rnorm, & + "The normalized radius dependence of the axisymmetric inflow angle "//& + "for the parametric idealized hurricane.", & + default=-0.9, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_AXI_INFLOW_MAX_SPEED", CS%A0_speed, & + "The maximum wind speed dependence of the axisymmetric inflow angle "//& + "for the parametric idealized hurricane.", & + default=-0.09, units="degrees s m-1", scale=US%L_T_to_m_s) + call get_param(param_file, mdl, "IDL_HURR_ASYM_INFLOW_0", CS%A1_0, & + "The zero-radius, zero-speed intercept of the normalized inflow angle asymmetry "//& + "for the parametric idealized hurricane.", & + default=0.14, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_ASYM_INFLOW_RNORM", CS%A1_Rnorm, & + "The normalized radius dependence of the normalized inflow angle asymmetry "//& + "for the parametric idealized hurricane.", & + default=0.04, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_ASYM_INFLOW_TR_SPEED", CS%A1_speed, & + "The translation speed dependence of the normalized inflow angle asymmetry "//& + "for the parametric idealized hurricane.", & + default=0.05, units="degrees s m-1", scale=US%L_T_to_m_s) + call get_param(param_file, mdl, "IDL_HURR_INFLOW_DANGLE_0", CS%P1_0, & + "The zero-radius, zero-speed intercept of the angle difference between the "//& + "translation direction and the inflow direction "//& + "for the parametric idealized hurricane.", & + default=85.31, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_INFLOW_DANGLE_RNORM", CS%P1_Rnorm, & + "The normalized radius dependence of the angle difference between the "//& + "translation direction and the inflow direction "//& + "for the parametric idealized hurricane.", & + default=6.88, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_INFLOW_DANGLE_TR_SPEED", CS%P1_speed, & + "The translation speed dependence of the angle difference between the "//& + "translation direction and the inflow direction"//& + "for the parametric idealized hurricane.", & + default=-9.60, units="degrees s m-1", scale=US%L_T_to_m_s) + ! Parameters for SCM mode - call get_param(param_file, mdl, "IDL_HURR_SCM_BR_BENCH", CS%BR_BENCH, & + call get_param(param_file, mdl, "IDL_HURR_SCM_BR_BENCH", CS%BR_Bench, & "Single column mode benchmark case switch, which is "// & "invoking a modification (bug) in the wind profile meant to "//& "reproduce a previous implementation.", default=.false.) - call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_MODE, & + call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_mode, & "Single Column mode switch used in the SCM idealized hurricane wind profile.", & default=.false.) + call get_param(param_file, mdl, "IDL_HURR_SCM_EDGE_TAPER_BUG", CS%edge_taper_bug, & + "If true and IDL_HURR_SCM is true, use a bug that does all of the tapering and "//& + "inflow angle calculations for radii between RAD_EDGE and RAD_AMBIENT as though "//& + "they were at RAD_EDGE.", & + default=CS%SCM_mode, do_not_log=.not.CS%SCM_mode) !### Change the default to false. + if (.not.CS%SCM_mode) CS%edge_taper_bug = .false. call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%dy_from_center, & - "Y distance of station used in the SCM idealized hurricane "//& - "wind profile.", units='m', default=50.e3, scale=US%m_to_L) + "Y distance of station used in the SCM idealized hurricane wind profile.", & + units='m', default=50.e3, scale=US%m_to_L) + call get_param(param_file, mdl, "IDL_HURR_SCM_CORIOLIS", CS%f_column, & + "Coriolis parameter used in the single column mode idealized hurricane wind profile.", & + units='s-1', default=5.5659e-05, scale=US%T_to_s, do_not_log=.not.CS%BR_Bench) ! (CS%SCM_mode) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -176,6 +264,48 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "values use expressions that are rescalable and respect rotational symmetry.", & default=default_answer_date) + ! Parameters for the simple Cdrag expression + call get_param(param_file, mdl, "IDL_HURR_CD_CALM", CS%Cd_calm, & + "The drag coefficient with weak relative winds "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='nondim', default=1.2e-3) + call get_param(param_file, mdl, "IDL_HURR_CD_CALM_SPEED", CS%calm_speed, & + "The relative wind speed below which the drag coefficient takes its calm value "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='m s-1', default=11.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "IDL_HURR_CD_WINDY", CS%Cd_windy, & + "The drag coefficient with strong relative winds "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='nondim', default=1.8e-3) + call get_param(param_file, mdl, "IDL_HURR_CD_WINDY_SPEED", CS%windy_speed, & + "The relative wind speed below which the drag coefficient takes its windy value "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='m s-1', default=20.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "IDL_HURR_CD_CONTINUOUS", continuous_Cd, & + "If true, use a continuous form for the simple drag coefficient as a function of "//& + "wind speed with the idealized hurricane. When this is false, the linear shape "//& + "for the mid-range wind speeds is specified separately.", & + default=.false.) + call get_param(param_file, mdl, "IDL_HURR_CD_DCD_DU10", CS%dCd_dU10, & + "The partial derivative of the drag coefficient times 1000 with the 10 m wind speed "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units="s m-1", default=0.065, scale=US%L_T_to_m_s, do_not_log=continuous_Cd) + call get_param(param_file, mdl, "IDL_HURR_CD_INTERCEPT", CS%Cd_intercept, & + "The zero-wind intercept times 1000 of the linear fit for the drag coefficient "//& + "for the intermediate speeds where there is a linear dependence on the 10 m wind speed "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units="nondim", default=0.49, do_not_log=continuous_Cd) + if (continuous_Cd) then + if (CS%windy_speed > CS%calm_speed) then + CS%dCd_dU10 = (CS%Cd_windy - CS%Cd_calm) / (CS%windy_speed - CS%calm_speed) + CS%Cd_intercept = CS%Cd_calm - CS%dCd_dU10 * CS%calm_speed + else + CS%dCd_dU10 = 0.0 + CS%Cd_intercept = CS%Cd_windy + endif + endif + + ! The following parameters are model run-time parameters which are used ! and logged elsewhere and so should not be logged here. The default ! value should be consistent with the rest of the model. @@ -189,9 +319,9 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "The background gustiness in the winds.", & units="Pa", default=0.0, scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, do_not_log=.true.) - if (CS%BR_BENCH) then - CS%rho_a = 1.2*US%kg_m3_to_R - endif + if (CS%rad_edge >= CS%rad_ambient) call MOM_error(FATAL, & + "idealized_hurricane_wind_init: IDL_HURR_RAD_AMBIENT must be larger than IDL_HURR_RAD_EDGE.") + dP = CS%pressure_ambient - CS%pressure_central if (CS%answer_date < 20190101) then C = CS%max_windspeed / sqrt( US%R_to_kg_m3 * dP ) @@ -199,8 +329,6 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) else CS%Holland_B = CS%max_windspeed**2 * CS%rho_a * exp(1.0) / dP endif - CS%Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B - CS%Holland_AxBxDP = CS%Holland_A*CS%Holland_B*dP end subroutine idealized_hurricane_wind_init @@ -225,6 +353,7 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) real :: fbench !< The benchmark 'f' value [T-1 ~> s-1] real :: fbench_fac !< A factor that is set to 0 to use the !! benchmark 'f' value [nondim] + real :: km_to_L !< The conversion factor from the units of latitude to L [L km-1 ~> 1e3] real :: rel_tau_fac !< A factor that is set to 0 to disable !! current relative stress calculation [nondim] @@ -234,6 +363,8 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + km_to_L = 1.0e3*US%m_to_L + ! Allocate the forcing arrays, if necessary. call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) @@ -252,7 +383,7 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) if (CS%BR_Bench) then ! f reset to value used in generated wind for benchmark test - fbench = 5.5659e-05 * US%T_to_s + fbench = CS%f_column fbench_fac = 0.0 else fbench = 0.0 @@ -267,17 +398,17 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) Vocn = 0.25*(sfc_state%v(i,J)+sfc_state%v(i+1,J-1)& +sfc_state%v(i+1,J)+sfc_state%v(i,J-1))*REL_TAU_FAC else - Vocn =0.25*((sfc_state%v(i,J)+sfc_state%v(i+1,J-1)) +& - (sfc_state%v(i+1,J)+sfc_state%v(i,J-1))) * REL_TAU_FAC + Vocn = 0.25*((sfc_state%v(i,J)+sfc_state%v(i+1,J-1)) +& + (sfc_state%v(i+1,J)+sfc_state%v(i,J-1))) * REL_TAU_FAC endif f_local = abs(0.5*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then - YY = YC + CS%dy_from_center - XX = XC + YY = CS%dy_from_center - YC + XX = -XC else - YY = G%geoLatCu(I,j)*1000.*US%m_to_L - YC - XX = G%geoLonCu(I,j)*1000.*US%m_to_L - XC + YY = G%geoLatCu(I,j)*km_to_L - YC + XX = G%geoLonCu(I,j)*km_to_L - XC endif call idealized_hurricane_wind_profile(CS, US, f_local, YY, XX, Uocn, Vocn, TX, TY) forces%taux(I,j) = G%mask2dCu(I,j) * TX @@ -297,11 +428,11 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) f_local = abs(0.5*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then - YY = YC + CS%dy_from_center - XX = XC + YY = CS%dy_from_center - YC + XX = -XC else - YY = G%geoLatCv(i,J)*1000.*US%m_to_L - YC - XX = G%geoLonCv(i,J)*1000.*US%m_to_L - XC + YY = G%geoLatCv(i,J)*km_to_L - YC + XX = G%geoLonCv(i,J)*km_to_L - XC endif call idealized_hurricane_wind_profile(CS, US, f_local, YY, XX, Uocn, Vocn, TX, TY) forces%tauy(i,J) = G%mask2dCv(i,J) * TY @@ -347,30 +478,41 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ! Wind profile terms real :: U10 ! The 10 m wind speed [L T-1 ~> m s-1] real :: radius ! The distance from the hurricane center [L ~> m] - real :: radius10 ! 10 times the distance from the hurricane center [L ~> m] + real :: radius10 ! The distance from the hurricane center to its edge [L ~> m] real :: radius_km ! The distance from the hurricane center, perhaps in km [L ~> m] or [1000 L ~> km] - real :: radiusB - real :: tmp ! A temporary variable [R L T-1 ~> kg m-2 s-1] real :: du10 ! The magnitude of the difference between the 10 m wind and the ocean flow [L T-1 ~> m s-1] real :: du ! The difference between the zonal 10 m wind and the zonal ocean flow [L T-1 ~> m s-1] real :: dv ! The difference between the meridional 10 m wind and the zonal ocean flow [L T-1 ~> m s-1] - real :: CD + real :: Cd ! The drag coefficient [nondim] + ! These variables with weird units are only used with pre-20240501 expressions + real :: radiusB ! A rescaled radius in m raised to the variable power CS%Holland_B [m^B] + real :: Holland_A ! Parameter 'A' from the Holland formula, in units of m raised to Holland_B [m^B] + real :: Holland_AxBxDP ! 'A' x 'B' x (Pressure Ambient-Pressure central) + ! for the Holland profile calculation [m^B R L2 T-2 ~> m^B Pa] + real :: tmp ! A temporary variable [m^B R L T-1 ~> m^B kg m-2 s-1] + ! These variables are used with expressions from 20240501 or later + real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] + real :: tmpA ! A temporary variable [R L2 T-2 ~> Pa] + real :: tmpB ! A temporary variable [R L T-1 ~> kg m-2 s-1] + real :: rad_max_rad_B ! The radius of maximum wind divided by the distance from the center raised + ! to the power of Holland_B [nondim] + real :: rad_rad_max ! The radius normalized by the radius of maximum winds [nondim] !Wind angle variables - real :: Alph !< The resulting inflow angle (positive outward) - real :: Rstr - real :: A0 - real :: A1 - real :: P1 - real :: Adir + real :: Alph ! The wind inflow angle (positive outward) [radians] + real :: Rstr ! A function of the position normalized by the radius of maximum winds [nondim] + real :: A0 ! The axisymmetric inflow angle [degrees] + real :: A1 ! The inflow angle asymmetry [degrees] + real :: P1 ! The angle difference between the translation direction and the inflow direction [radians] + real :: Adir ! The angle of the direction from the center to a point [radians] real :: V_TS ! Meridional hurricane translation speed [L T-1 ~> m s-1] real :: U_TS ! Zonal hurricane translation speed [L T-1 ~> m s-1] - ! Implementing Holland (1980) parameteric wind profile + ! Implementing Holland (1980) parametric wind profile radius = SQRT((XX**2) + (YY**2)) + rad_rad_max = radius / CS%rad_max_wind - !/ BGR ! rkm - r converted to km for Holland prof. ! used in km due to error, correct implementation should ! not need rkm, but to match winds w/ experiment this must @@ -382,17 +524,24 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ! if not comparing to benchmark, then use correct Holland prof. radius_km = radius endif - radiusB = (US%L_to_m*radius)**CS%Holland_B !/ - ! Calculate U10 in the interior (inside of 10x radius of maximum wind), - ! while adjusting U10 to 0 outside of 12x radius of maximum wind. + ! Calculate U10 in the interior (inside of the hurricane edge radius), + ! while adjusting U10 to 0 outside of the ambient wind radius. if (CS%answer_date < 20190101) then - if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < 10.*CS%rad_max_wind) ) then - U10 = sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB) / (CS%rho_a*radiusB) + & + radiusB = (US%L_to_m*radius)**CS%Holland_B + Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B + if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < CS%rad_edge*CS%rad_max_wind) ) then + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) + U10 = sqrt(Holland_AxBxDP*exp(-Holland_A/radiusB) / (CS%rho_a*radiusB) + & 0.25*(radius_km*absf)**2) - 0.5*radius_km*absf - elseif ( (radius > 10.*CS%rad_max_wind) .and. (radius < 15.*CS%rad_max_wind) ) then - radius10 = CS%rad_max_wind*10. + elseif ( (radius > CS%rad_edge*CS%rad_max_wind) .and. (radius < CS%rad_ambient*CS%rad_max_wind) ) then + if (CS%edge_taper_bug) then ! This recreates a bug that was in SCM_idealized_hurricane_wind_forcing. + radius = CS%rad_edge * CS%rad_max_wind + rad_rad_max = CS%rad_edge + endif + + radius10 = CS%rad_max_wind*CS%rad_edge if (CS%BR_Bench) then radius_km = radius10/1000. else @@ -400,24 +549,64 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx endif radiusB = (US%L_to_m*radius10)**CS%Holland_B - U10 = (sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) / (CS%rho_a*radiusB) + & + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) + U10 = (sqrt(Holland_AxBxDp*exp(-Holland_A/radiusB) / (CS%rho_a*radiusB) + & 0.25*(radius_km*absf)**2) - 0.5*radius_km*absf) & - * (15. - radius/CS%rad_max_wind)/5. + * (CS%rad_ambient - radius/CS%rad_max_wind) / (CS%rad_ambient - CS%rad_edge) else U10 = 0. endif - else ! This is mathematically equivalent to that is above but more accurate. - if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < 10.*CS%rad_max_wind) ) then + elseif (CS%answer_date < 20240501) then + ! This is mathematically equivalent to that is above but more accurate. + radiusB = (US%L_to_m*radius)**CS%Holland_B + Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B + if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < CS%rad_edge*CS%rad_max_wind) ) then + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) tmp = ( 0.5*radius_km*absf) * (CS%rho_a*radiusB) - U10 = (CS%Holland_AxBxDP * exp(-CS%Holland_A/radiusB)) / & - ( tmp + sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) - elseif ( (radius > 10.*CS%rad_max_wind) .and. (radius < 15.*CS%rad_max_wind) ) then - radius_km = 10.0 * CS%rad_max_wind + U10 = (Holland_AxBxDP * exp(-Holland_A/radiusB)) / & + ( tmp + sqrt(Holland_AxBxDP*exp(-Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + elseif ( (radius > CS%rad_edge*CS%rad_max_wind) .and. (radius < CS%rad_ambient*CS%rad_max_wind) ) then + if (CS%edge_taper_bug) then ! This recreates a bug that was in SCM_idealized_hurricane_wind_forcing. + radius = CS%rad_edge * CS%rad_max_wind + rad_rad_max = CS%rad_edge + endif + + radius_km = CS%rad_edge * CS%rad_max_wind if (CS%BR_Bench) radius_km = radius_km/1000. - radiusB = (10.0*US%L_to_m*CS%rad_max_wind)**CS%Holland_B + radiusB = (CS%rad_edge*US%L_to_m*CS%rad_max_wind)**CS%Holland_B tmp = ( 0.5*radius_km*absf) * (CS%rho_a*radiusB) - U10 = (3.0 - radius/(5.0*CS%rad_max_wind)) * (CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) ) / & - ( tmp + sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) + U10 = ((CS%rad_ambient/(CS%rad_ambient - CS%rad_edge)) - & + radius/((CS%rad_ambient - CS%rad_edge)*CS%rad_max_wind)) * & + (Holland_AxBxDp*exp(-Holland_A/radiusB) ) / & + ( tmp + sqrt(Holland_AxBxDp*exp(-Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + else + U10 = 0.0 + endif + else + ! This is mathematically equivalent to the expressions above, but allows for full + ! dimensional consistency testing. + dP = CS%pressure_ambient - CS%pressure_central + if ( (rad_rad_max > 0.001) .and. (rad_rad_max <= CS%rad_edge) ) then + rad_max_rad_B = (rad_rad_max)**(-CS%Holland_B) + tmpA = (rad_max_rad_B*CS%Holland_B) * dp + tmpB = (0.5*radius_km*absf) * CS%rho_a + U10 = ( tmpA * exp(-rad_max_rad_B) ) / & + ( tmpB + sqrt( (tmpA * CS%rho_a) * exp(-rad_max_rad_B) + tmpB**2) ) + elseif ( (rad_rad_max > CS%rad_edge) .and. (rad_rad_max < CS%rad_ambient) ) then + if (CS%edge_taper_bug) then ! This recreates a bug that was in SCM_idealized_hurricane_wind_forcing. + radius = CS%rad_edge * CS%rad_max_wind + rad_rad_max = CS%rad_edge + endif + + radius_km = CS%rad_edge * CS%rad_max_wind + if (CS%BR_Bench) radius_km = radius_km * 0.001 + rad_max_rad_B = CS%rad_edge**(-CS%Holland_B) + tmpA = (rad_max_rad_B*CS%Holland_B) * dp + tmpB = (0.5*radius_km*absf) * CS%rho_a + U10 = ((CS%rad_ambient - rad_rad_max) * ( tmpA * exp(-rad_max_rad_B) )) / & + ((CS%rad_ambient - CS%rad_edge) * & + ( tmpB + sqrt((tmpA * CS%rho_a) * exp(-rad_max_rad_B) + tmpB**2) ) ) else U10 = 0.0 endif @@ -429,45 +618,42 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ! Wind angle model following Zhang and Ulhorn (2012) ! ALPH is inflow angle positive outward. - RSTR = min(10., radius / CS%rad_max_wind) - A0 = -0.9*RSTR - 0.09*US%L_T_to_m_s*CS%max_windspeed - 14.33 - A1 = -A0*(0.04*RSTR + 0.05*US%L_T_to_m_s*CS%hurr_translation_spd + 0.14) - P1 = (6.88*RSTR - 9.60*US%L_T_to_m_s*CS%hurr_translation_spd + 85.31) * CS%Deg2Rad - ALPH = A0 - A1*cos(CS%hurr_translation_dir-Adir-P1) - if ( (radius > 10.*CS%rad_max_wind) .and.& - (radius < 15.*CS%rad_max_wind) ) then - ALPH = ALPH*(15.0 - radius/CS%rad_max_wind)/5. - elseif (radius > 15.*CS%rad_max_wind) then - ALPH = 0.0 + RSTR = min(CS%rad_edge, rad_rad_max) + if (CS%answer_date < 20240501) then + A0 = CS%A0_Rnorm*RSTR + CS%A0_speed*CS%max_windspeed + CS%A0_0 + A1 = -A0*(CS%A1_Rnorm*RSTR + CS%A1_speed*CS%hurr_translation_spd + CS%A1_0) + P1 = (CS%P1_Rnorm*RSTR + CS%P1_speed*CS%hurr_translation_spd + CS%P1_0) * CS%Deg2Rad + ALPH = A0 - A1*cos(CS%hurr_translation_dir-Adir-P1) + if ( (radius > CS%rad_edge*CS%rad_max_wind) .and. (radius < CS%rad_ambient*CS%rad_max_wind) ) then + ALPH = ALPH*(CS%rad_ambient - rad_rad_max) / (CS%rad_ambient - CS%rad_edge) + elseif (radius > CS%rad_ambient*CS%rad_max_wind) then ! This should be >= to avoid a jump at CS%rad_ambient + ALPH = 0.0 + endif + ALPH = ALPH * CS%Deg2Rad + else + A0 = (CS%A0_Rnorm*RSTR + CS%A0_speed*CS%max_windspeed) + CS%A0_0 + A1 = -A0*((CS%A1_Rnorm*RSTR + CS%A1_speed*CS%hurr_translation_spd) + CS%A1_0) + P1 = ((CS%P1_Rnorm*RSTR + CS%P1_speed*CS%hurr_translation_spd) + CS%P1_0) * CS%Deg2Rad + ALPH = (A0 - A1*cos((CS%hurr_translation_dir- Adir) - P1) ) * CS%Deg2Rad + if (rad_rad_max > CS%rad_edge) & + ALPH = ALPH * (max(CS%rad_ambient - rad_rad_max, 0.0) / (CS%rad_ambient - CS%rad_edge)) endif - ALPH = ALPH * CS%Deg2Rad ! Calculate translation speed components U_TS = CS%hurr_translation_spd * 0.5*cos(CS%hurr_translation_dir) V_TS = CS%hurr_translation_spd * 0.5*sin(CS%hurr_translation_dir) ! Set output (relative) winds - dU = U10*sin(Adir-CS%Pi-Alph) - Uocn + U_TS + dU = U10*sin(Adir-CS%pi-Alph) - Uocn + U_TS dV = U10*cos(Adir-Alph) - Vocn + V_TS ! Use a simple drag coefficient as a function of U10 (from Sullivan et al., 2010) du10 = sqrt((du**2) + (dv**2)) - if (dU10 < 11.0*US%m_s_to_L_T) then - Cd = 1.2e-3 - elseif (dU10 < 20.0*US%m_s_to_L_T) then - if (CS%answer_date < 20190101) then - Cd = (0.49 + 0.065*US%L_T_to_m_s*U10)*1.e-3 - else - Cd = (0.49 + 0.065*US%L_T_to_m_s*dU10)*1.e-3 - endif - else - Cd = 1.8e-3 - endif + Cd = simple_wind_scaled_Cd(u10, du10, CS) ! Compute stress vector - TX = US%L_to_Z * CS%rho_a * Cd * sqrt((dU**2) + (dV**2)) * dU - TY = US%L_to_Z * CS%rho_a * Cd * sqrt((dU**2) + (dV**2)) * dV - + TX = US%L_to_Z * CS%rho_a * Cd * du10 * dU + TY = US%L_to_Z * CS%rho_a * Cd * du10 * dV end subroutine idealized_hurricane_wind_profile !> This subroutine is primarily needed as a legacy for reproducing answers. @@ -484,24 +670,34 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: pie, Deg2Rad real :: du10 ! The magnitude of the difference between the 10 m wind and the ocean flow [L T-1 ~> m s-1] real :: U10 ! The 10 m wind speed [L T-1 ~> m s-1] - real :: A, B, C ! For wind profile expression + real :: A ! The radius of the maximum winds raised to the power given by B, used in the + ! wind profile expression, in [km^B] + real :: B ! A power used in the wind profile expression [nondim] + real :: C ! A temporary variable in units of the square root of a specific volume [sqrt(m3 kg-1)] real :: rad ! The distance from the hurricane center [L ~> m] + real :: radius10 ! The distance from the hurricane center to its edge [L ~> m] real :: rkm ! The distance from the hurricane center, sometimes scaled to km [L ~> m] or [1000 L ~> km] real :: f_local ! The local Coriolis parameter [T-1 ~> s-1] real :: xx ! x-position [L ~> m] - real :: t0 !for location + real :: t0 ! Time at which the eye crosses the origin [T ~> s] real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] - real :: rB - real :: Cd ! Air-sea drag coefficient + real :: rB ! The distance from the center raised to the power given by B, in [m^B] + ! or [km^B] if BR_Bench is true. + real :: Cd ! Air-sea drag coefficient [nondim] real :: Uocn, Vocn ! Surface ocean velocity components [L T-1 ~> m s-1] real :: dU, dV ! Air-sea differential motion [L T-1 ~> m s-1] - !Wind angle variables - real :: Alph,Rstr, A0, A1, P1, Adir, transdir + ! Wind angle variables + real :: Alph ! The wind inflow angle (positive outward) [radians] + real :: Rstr ! A function of the position normalized by the radius of maximum winds [nondim] + real :: A0 ! The axisymmetric inflow angle [degrees] + real :: A1 ! The inflow angle asymmetry [degrees] + real :: P1 ! The angle difference between the translation direction and the inflow direction [radians] + real :: Adir ! The angle of the direction from the center to a point [radians] + real :: transdir ! Translation direction [radians] real :: V_TS, U_TS ! Components of the translation speed [L T-1 ~> m s-1] - logical :: BR_Bench + ! Bounds for loops and memory allocation is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -509,46 +705,46 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) - pie = 4.0*atan(1.0) ; Deg2Rad = pie/180. - !/ BR + ! Implementing Holland (1980) parameteric wind profile - !------------------------------------------------------| - BR_Bench = .true. !true if comparing to LES runs | - t0 = 129600. !TC 'eye' crosses (0,0) at 36 hours| - transdir = pie !translation direction (-x) | - !------------------------------------------------------| + !------------------------------------------------------------| + t0 = 129600.*US%s_to_T ! TC 'eye' crosses (0,0) at 36 hours | + transdir = CS%pi ! translation direction (-x) | + !------------------------------------------------------------| dP = CS%pressure_ambient - CS%pressure_central if (CS%answer_date < 20190101) then C = CS%max_windspeed / sqrt( US%R_to_kg_m3*dP ) B = C**2 * US%R_to_kg_m3*CS%rho_a * exp(1.0) - if (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test + if (CS%BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test B = C**2 * 1.2 * exp(1.0) endif - elseif (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test - B = (CS%max_windspeed**2 / dP ) * 1.2*US%kg_m3_to_R * exp(1.0) else - B = (CS%max_windspeed**2 /dP ) * CS%rho_a * exp(1.0) + B = (CS%max_windspeed**2 / dP ) * CS%rho_a * exp(1.0) endif - A = (US%L_to_m*CS%rad_max_wind / 1000.)**B - f_local = G%CoriolisBu(is,js) ! f=f(x,y) but in the SCM is constant - if (BR_Bench) then - ! f reset to value used in generated wind for benchmark test - f_local = 5.5659e-05*US%T_to_s + if (CS%BR_Bench) then + A = (US%L_to_m*CS%rad_max_wind / 1000.)**B + else + A = (US%L_to_m*CS%rad_max_wind)**B + endif + ! f_local = f(x,y), but in the SCM it is constant + if (CS%BR_Bench) then ! (CS%SCM_mode) then + f_local = CS%f_column + else + f_local = G%CoriolisBu(is,js) endif - !/ BR - ! Calculate x position as a function of time. - xx = US%s_to_T*( t0 - time_type_to_real(day)) * CS%hurr_translation_spd * cos(transdir) + + ! Calculate x position relative to hurricane center as a function of time. + xx = (t0 - time_type_to_real(day)*US%s_to_T) * CS%hurr_translation_spd * cos(transdir) rad = sqrt((xx**2) + (CS%dy_from_center**2)) - !/ BR + ! rkm - rad converted to km for Holland prof. ! used in km due to error, correct implementation should ! not need rkm, but to match winds w/ experiment this must ! be maintained. Causes winds far from storm center to be a ! couple of m/s higher than the correct Holland prof. - if (BR_Bench) then + if (CS%BR_Bench) then rkm = rad/1000. rB = (US%L_to_m*rkm)**B else @@ -556,43 +752,42 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C rkm = rad rB = (US%L_to_m*rad)**B endif - !/ BR - ! Calculate U10 in the interior (inside of 10x radius of maximum wind), - ! while adjusting U10 to 0 outside of 12x radius of maximum wind. - ! Note that rho_a is set to 1.2 following generated wind for experiment - if (rad > 0.001*CS%rad_max_wind .AND. rad < 10.*CS%rad_max_wind) then - U10 = sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local - elseif (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then - rad=(CS%rad_max_wind)*10. - if (BR_Bench) then - rkm = rad/1000. + + ! Calculate U10 in the interior (inside of the hurricane edge radius), + ! while adjusting U10 to 0 outside of the ambient wind radius. + if (rad > 0.001*CS%rad_max_wind .AND. rad < CS%rad_edge*CS%rad_max_wind) then + U10 = sqrt( A*B*dP*exp(-A/rB)/(CS%rho_a*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local + elseif (rad > CS%rad_edge*CS%rad_max_wind .AND. rad < CS%rad_ambient*CS%rad_max_wind) then + radius10 = CS%rad_max_wind*CS%rad_edge + if (CS%BR_Bench) then + rkm = radius10/1000. rB = (US%L_to_m*rkm)**B else - rkm = rad - rB = (US%L_to_m*rad)**B + rkm = radius10 + rB = (US%L_to_m*radius10)**B endif - U10 = ( sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local) & - * (12. - rad/CS%rad_max_wind)/2. + if (CS%edge_taper_bug) rad = radius10 + U10 = ( sqrt( A*B*dP*exp(-A/rB)/(CS%rho_a*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local) & + * (CS%rad_ambient - rad/CS%rad_max_wind)/(CS%rad_ambient - CS%rad_edge) else U10 = 0. endif Adir = atan2(CS%dy_from_center,xx) - !/ BR ! Wind angle model following Zhang and Ulhorn (2012) ! ALPH is inflow angle positive outward. - RSTR = min(10., rad / CS%rad_max_wind) - A0 = -0.9*RSTR - 0.09*US%L_T_to_m_s*CS%max_windspeed - 14.33 - A1 = -A0 *(0.04*RSTR + 0.05*US%L_T_to_m_s*CS%hurr_translation_spd + 0.14) - P1 = (6.88*RSTR - 9.60*US%L_T_to_m_s*CS%hurr_translation_spd + 85.31)*pie/180. + RSTR = min(CS%rad_edge, rad / CS%rad_max_wind) + A0 = CS%A0_Rnorm*RSTR + CS%A0_speed*CS%max_windspeed + CS%A0_0 + A1 = -A0*(CS%A1_Rnorm*RSTR + CS%A1_speed*CS%hurr_translation_spd + CS%A1_0) + P1 = (CS%P1_Rnorm*RSTR + CS%P1_speed*CS%hurr_translation_spd + CS%P1_0) * CS%pi/180. ALPH = A0 - A1*cos( (TRANSDIR - ADIR ) - P1) - if (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then - ALPH = ALPH* (12. - rad/CS%rad_max_wind)/2. - elseif (rad > 12.*CS%rad_max_wind) then + if (rad > CS%rad_edge*CS%rad_max_wind .AND. rad < CS%rad_ambient*CS%rad_max_wind) then + ALPH = ALPH* (CS%rad_ambient - rad/CS%rad_max_wind) / (CS%rad_ambient - CS%rad_edge) + elseif (rad > CS%rad_ambient*CS%rad_max_wind) then ALPH = 0.0 endif - ALPH = ALPH * Deg2Rad - !/BR + ALPH = ALPH * CS%Deg2Rad + ! Prepare for wind calculation ! X_TS is component of translation speed added to wind vector ! due to background steering wind. @@ -604,55 +799,33 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. do j=js,je ; do I=is-1,Ieq - !/BR ! Turn off surface current for stress calculation to be ! consistent with test case. Uocn = 0. ! sfc_state%u(I,j) Vocn = 0. ! 0.25*( (sfc_state%v(i,J) + sfc_state%v(i+1,J-1)) + & ! (sfc_state%v(i+1,J) + sfc_state%v(i,J-1)) ) - !/BR ! Wind vector calculated from location/direction (sin/cos flipped b/c ! cyclonic wind is 90 deg. phase shifted from position angle). - dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS - dV = U10*cos(Adir-Alph) - Vocn + V_TS + dU = U10*sin(Adir - CS%pi - Alph) - Uocn + U_TS + dV = U10*cos(Adir - Alph) - Vocn + V_TS !/----------------------------------------------------| - !BR ! Add a simple drag coefficient as a function of U10 | !/----------------------------------------------------| du10 = sqrt((du**2) + (dv**2)) - if (dU10 < 11.0*US%m_s_to_L_T) then - Cd = 1.2e-3 - elseif (dU10 < 20.0*US%m_s_to_L_T) then - if (CS%answer_date < 20190101) then - Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 - else - Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 - endif - else - Cd = 0.0018 - endif + Cd = simple_wind_scaled_Cd(u10, du10, CS) + forces%taux(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCu(I,j) * Cd*du10*dU enddo ; enddo - !/BR + ! See notes above do J=js-1,Jeq ; do i=is,ie Uocn = 0. ! 0.25*( (sfc_state%u(I,j) + sfc_state%u(I-1,j+1)) + & ! (sfc_state%u(I-1,j) + sfc_state%u(I,j+1)) ) Vocn = 0. ! sfc_state%v(i,J) - dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS + dU = U10*sin(Adir - CS%pi - Alph) - Uocn + U_TS dV = U10*cos(Adir-Alph) - Vocn + V_TS du10 = sqrt((du**2) + (dv**2)) - if (dU10 < 11.0*US%m_s_to_L_T) then - Cd = 1.2e-3 - elseif (dU10 < 20.0*US%m_s_to_L_T) then - if (CS%answer_date < 20190101) then - Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 - else - Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 - endif - else - Cd = 0.0018 - endif + Cd = simple_wind_scaled_Cd(u10, du10, CS) forces%tauy(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCv(I,j) * Cd*dU10*dV enddo ; enddo @@ -673,4 +846,27 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C end subroutine SCM_idealized_hurricane_wind_forcing +!> This function returns the air-sea drag coefficient using a simple function of the air-sea velocity difference. +function simple_wind_scaled_Cd(u10, du10, CS) result(Cd) + real, intent(in) :: U10 !< The 10 m wind speed [L T-1 ~> m s-1] + real, intent(in) :: du10 !< The magnitude of the difference between the 10 m wind + !! and the ocean flow [L T-1 ~> m s-1] + type(idealized_hurricane_CS), pointer :: CS !< Container for SCM parameters + real :: Cd ! Air-sea drag coefficient [nondim] + + ! Note that these expressions are discontinuous at dU10 = 11 and 20 m s-1. + if (dU10 < CS%calm_speed) then + Cd = CS%Cd_calm + elseif (dU10 < CS%windy_speed) then + if (CS%answer_date < 20190101) then + Cd = (CS%Cd_intercept + CS%dCd_dU10 * U10 )*0.001 + else + Cd = (CS%Cd_intercept + CS%dCd_dU10 * dU10 )*0.001 + endif + else + Cd = CS%Cd_windy + endif + +end function simple_wind_scaled_Cd + end module idealized_hurricane diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 08484da1f8..d2f2072223 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -59,6 +59,9 @@ module MOM_wave_interface logical, public :: Stokes_VF = .false. !< True if Stokes vortex force is used logical, public :: Passive_Stokes_VF = .false. !< Computes Stokes VF, but doesn't affect dynamics logical, public :: Stokes_PGF = .false. !< True if Stokes shear pressure Gradient force is used + logical, public :: robust_Stokes_PGF = .false. !< If true, use expressions to calculate the + !! Stokes-induced pressure gradient anomalies that are + !! more accurate in the limit of thin layers. logical, public :: Passive_Stokes_PGF = .false. !< Keeps Stokes_PGF on, but doesn't affect dynamics logical, public :: Stokes_DDT = .false. !< Developmental: !! True if Stokes d/dt is used @@ -164,6 +167,8 @@ module MOM_wave_interface real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number [nondim] real :: LA_HBL_min !< Minimum boundary layer depth for averaging Langmuir number [Z ~> m] logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number + logical :: LA_misalign_bug = .false. !< Flag to use code with a sign error when calculating the + !! misalignment between the shear and waves in the Langmuir number calculation. 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] @@ -377,22 +382,27 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) call get_param(param_file, mdl, "STOKES_VF", CS%Stokes_VF, & "Flag to use Stokes vortex force", & - Default=.false.) + default=.false.) call get_param(param_file, mdl, "PASSIVE_STOKES_VF", CS%Passive_Stokes_VF, & "Flag to make Stokes vortex force diagnostic only.", & - Default=.false.) + default=.false.) call get_param(param_file, mdl, "STOKES_PGF", CS%Stokes_PGF, & "Flag to use Stokes-induced pressure gradient anomaly", & - Default=.false.) + default=.false.) + call get_param(param_file, mdl, "ROBUST_STOKES_PGF", CS%robust_Stokes_PGF, & + "If true, use expressions to calculate the Stokes-induced pressure gradient "//& + "anomalies that are more accurate in the limit of thin layers.", & + default=.false., do_not_log=.not.CS%Stokes_PGF) + !### Change the default for ROBUST_STOKES_PGF to True. call get_param(param_file, mdl, "PASSIVE_STOKES_PGF", CS%Passive_Stokes_PGF, & "Flag to make Stokes-induced pressure gradient anomaly diagnostic only.", & - Default=.false.) + default=.false.) call get_param(param_file, mdl, "STOKES_DDT", CS%Stokes_DDT, & "Flag to use Stokes d/dt", & - Default=.false.) + default=.false.) call get_param(param_file, mdl, "PASSIVE_STOKES_DDT", CS%Passive_Stokes_DDT, & "Flag to make Stokes d/dt diagnostic only", & - Default=.false.) + default=.false.) ! Get Wave Method and write to integer WaveMethod call get_param(param_file,mdl,"WAVE_METHOD",TMPSTRING1, & @@ -526,6 +536,11 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) call get_param(param_file, mdl, "LA_MISALIGNMENT", CS%LA_Misalignment, & "Flag (logical) if using misalignment between shear and waves in LA", & default=.false.) + call get_param(param_file, mdl, "LA_MISALIGNMENT_BUG", CS%LA_misalign_bug, & + "If true, use a code with a sign error when calculating the misalignment between "//& + "the shear and waves when LA_MISALIGNMENT is true.", & + default=CS%LA_Misalignment, do_not_log=.not.CS%LA_Misalignment) + !### Change the default for LA_MISALIGNMENT_BUG to .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 "//& @@ -1030,6 +1045,18 @@ real function one_minus_exp_x(x) endif end function one_minus_exp_x +!> Return the value of (1 - exp(-x)), using an accurate expression for small values of x. +real function one_minus_exp(x) + real, intent(in) :: x !< The argument of the function ((1 - exp(-x))/x) [nondim] + real, parameter :: C1_6 = 1.0/6.0 ! A rational fraction [nondim] + 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 = 1.0 - exp(-x) + endif +end function one_minus_exp + !> A subroutine to fill the Stokes drift from a NetCDF file !! using the data_override procedures. subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS) @@ -1199,12 +1226,18 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, & Top = Bottom MidPoint = Bottom + 0.5*dz(k) Bottom = Bottom + dz(k) - !### Given the sign convention that Dpt_LASL is negative, the next line seems to have a bug. - ! To correct this bug, this line should be changed to: - ! if (MidPoint > abs(Dpt_LASL) .and. (k > 1) .and. ContinueLoop) then - if (MidPoint > Dpt_LASL .and. k > 1 .and. ContinueLoop) then - ShearDirection = atan2(V_H(1)-V_H(k), U_H(1)-U_H(k)) - ContinueLoop = .false. + + if (Waves%LA_Misalign_bug) then + ! Given the sign convention that Dpt_LASL is negative, the next line has a bug. + if (MidPoint > Dpt_LASL .and. k > 1 .and. ContinueLoop) then + ShearDirection = atan2(V_H(1)-V_H(k), U_H(1)-U_H(k)) + ContinueLoop = .false. + endif + else ! This version avoids the bug in the version above. + if (MidPoint > abs(Dpt_LASL) .and. (k > 1) .and. ContinueLoop) then + ShearDirection = atan2(V_H(1)-V_H(k), U_H(1)-U_H(k)) + ContinueLoop = .false. + endif endif enddo endif @@ -1706,7 +1739,9 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) real :: P_Stokes_l0, P_Stokes_r0 ! Stokes-induced pressure anomaly at interface ! (left/right of point) [L2 T-2 ~> m2 s-2] real :: dP_Stokes_l_dz, dP_Stokes_r_dz ! Contribution of layer to integrated Stokes pressure anomaly for summation - ! (left/right of point) [L3 T-2 ~> m3 s-2] + ! (left/right of point) [Z L2 T-2 ~> m3 s-2] + real :: dP_lay_Stokes_l, dP_lay_Stokes_r ! Contribution of layer to integrated Stokes pressure anomaly for summation + ! (left/right of point) [L2 T-2 ~> m2 s-2] real :: dP_Stokes_l, dP_Stokes_r ! Net increment of Stokes pressure anomaly across layer for summation ! (left/right of point) [L2 T-2 ~> m2 s-2] real :: uE_l, uE_r, vE_l, vE_r ! Eulerian velocity components (left/right of point) [L T-1 ~> m s-1] @@ -1714,6 +1749,7 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) real :: zi_l(SZK_(G)+1), zi_r(SZK_(G)+1) ! The height of the edges of the cells (left/right of point) [Z ~> m]. real :: idz_l(SZK_(G)), idz_r(SZK_(G)) ! The inverse thickness of the cells (left/right of point) [Z-1 ~> m-1] real :: h_l, h_r ! The thickness of the cell (left/right of point) [Z ~> m]. + real :: exp_top ! The decay of the surface stokes drift to the interface atop a layer [nondim] real :: dexp2kzL, dexp4kzL, dexp2kzR, dexp4kzR ! Analytical evaluation of multi-exponential decay ! contribution to Stokes pressure anomalies [nondim]. real :: TwoK, FourK ! Wavenumbers multiplied by a factor [Z-1 ~> m-1] @@ -1762,9 +1798,11 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) h_r = dz(i+1,j,k) zi_l(k+1) = zi_l(k) - h_l zi_r(k+1) = zi_r(k) - h_r - !### If the code were properly refactored, the following hard-coded constants would be unnecessary. - Idz_l(k) = 1./max(0.1*US%m_to_Z, h_l) - Idz_r(k) = 1./max(0.1*US%m_to_Z, h_r) + if (.not.CS%robust_Stokes_PGF) then + ! When the code is properly refactored, the following hard-coded constants are unnecessary. + Idz_l(k) = 1./max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1./max(0.1*US%m_to_Z, h_r) + endif enddo do k = 1,G%ke ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the @@ -1798,31 +1836,59 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) ! Wavenumber terms that are useful to simplify the pressure calculations TwoK = 2.*CS%WaveNum_Cen(l) FourK = 2.*TwoK - iTwoK = 1./TwoK - iFourK = 1./(FourK) - dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) - dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) - dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) - dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + if (.not.CS%robust_Stokes_PGF) then + iTwoK = 1. / TwoK + iFourK = 1. / FourK + endif ! Compute Pressure at interface and integrated over layer on left/right bounding points. ! These are summed over wavenumber bands. if (G%mask2dT(i,j)>0.5) then - dP_Stokes_l_dz = dP_Stokes_l_dz + & - ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) - dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + if (.not.CS%robust_Stokes_PGF) then + dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) + dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) + dP_Stokes_l_dz = dP_Stokes_l_dz + & + ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) + dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_l(k)) + dP_lay_Stokes_l = dP_lay_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp_x(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i,j,k)) ) + dP_Stokes_l = dP_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp(FourK*dz(i,j,k)) ) + endif endif if (G%mask2dT(i+1,j)>0.5) then - dP_Stokes_r_dz = dP_Stokes_r_dz + & - ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR) - dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR + if (.not.CS%robust_Stokes_PGF) then + dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) + dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + dP_Stokes_r_dz = dP_Stokes_r_dz + & + ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR) + dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_r(k)) + dP_lay_Stokes_r = dP_lay_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp_x(TwoK*dz(i+1,j,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i+1,j,k)) ) + dP_Stokes_r = dP_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp(TwoK*dz(i+1,j,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp(FourK*dz(i+1,j,k)) ) + endif endif enddo ! Summing PF over bands ! > Increment the Layer averaged pressure - P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) - P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + if (.not.CS%robust_Stokes_PGF) then + P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) + P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + else + P_Stokes_l = P_Stokes_l0 + dP_lay_Stokes_l + P_Stokes_r = P_Stokes_r0 + dP_lay_Stokes_r + endif + ! > Increment the Interface pressure P_Stokes_l0 = P_Stokes_l0 + dP_Stokes_l P_Stokes_r0 = P_Stokes_r0 + dP_Stokes_r @@ -1856,9 +1922,11 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) h_r = dz(i,j+1,k) zi_l(k+1) = zi_l(k) - h_l zi_r(k+1) = zi_r(k) - h_r - !### If the code were properly refactored, the following hard-coded constants would be unnecessary. - Idz_l(k) = 1. / max(0.1*US%m_to_Z, h_l) - Idz_r(k) = 1. / max(0.1*US%m_to_Z, h_r) + if (.not.CS%robust_Stokes_PGF) then + ! When the code is properly refactored, the following hard-coded constants are unnecessary. + Idz_l(k) = 1. / max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1. / max(0.1*US%m_to_Z, h_r) + endif enddo do k = 1,G%ke ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the @@ -1892,31 +1960,59 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) ! Wavenumber terms that are useful to simplify the pressure calculations TwoK = 2.*CS%WaveNum_Cen(l) FourK = 2.*TwoK - iTwoK = 1./TwoK - iFourK = 1./(FourK) - dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) - dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) - dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) - dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + if (.not.CS%robust_Stokes_PGF) then + iTwoK = 1. / TwoK + iFourK = 1. / FourK + endif ! Compute Pressure at interface and integrated over layer on left/right bounding points. ! These are summed over wavenumber bands. if (G%mask2dT(i,j)>0.5) then - dP_Stokes_l_dz = dP_Stokes_l_dz + & - ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) - dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + if (.not.CS%robust_Stokes_PGF) then + dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) + dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) + dP_Stokes_l_dz = dP_Stokes_l_dz + & + ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) + dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_l(k)) + dP_lay_Stokes_l = dP_lay_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp_x(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i,j,k)) ) + dP_Stokes_l = dP_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp(FourK*dz(i,j,k)) ) + endif endif if (G%mask2dT(i,j+1)>0.5) then - dP_Stokes_r_dz = dP_Stokes_r_dz + & - ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR) - dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR + if (.not.CS%robust_Stokes_PGF) then + dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) + dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + dP_Stokes_r_dz = dP_Stokes_r_dz + & + ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR) + dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_r(k)) + dP_lay_Stokes_r = dP_lay_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp_x(TwoK*dz(i,j+1,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i,j+1,k)) ) + dP_Stokes_r = dP_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp(TwoK*dz(i,j+1,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp(FourK*dz(i,j+1,k)) ) + endif endif enddo ! Summing PF over bands ! > Increment the Layer averaged pressure - P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) - P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + if (.not.CS%robust_Stokes_PGF) then + P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) + P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + else + P_Stokes_l = P_Stokes_l0 + dP_lay_Stokes_l + P_Stokes_r = P_Stokes_r0 + dP_lay_Stokes_r + endif + ! > Increment the Interface pressure P_Stokes_l0 = P_Stokes_l0 + dP_Stokes_l P_Stokes_r0 = P_Stokes_r0 + dP_Stokes_r @@ -1939,7 +2035,6 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) end subroutine Stokes_PGF - !> Computes wind speed from ustar_air based on COARE 3.5 Cd relationship !! Probably doesn't belong in this module, but it is used here to estimate !! wind speed for wind-wave relationships. Should be a fine way to estimate diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index 6102c2a5ef..1570cab7d3 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -62,7 +62,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salinity [S ~> ppt] real :: U1(SZIB_(G),SZJ_(G),SZK_(GV)) ! A temporary array for u [L T-1 ~> m s-1] real :: V1(SZI_(G),SZJB_(G),SZK_(GV)) ! A temporary array for v [L T-1 ~> m s-1] - real :: tmp(SZI_(G),SZJ_(G)) ! A temporary array for tracers. + real :: rho(SZI_(G),SZJ_(G)) ! A temporary array for mixed layer density [R ~> kg m-3]. real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge layer thicknesses in height units [Z ~> m] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate at h points [T-1 ~> s-1] real :: TNUDG ! Nudging time scale [T ~> s] @@ -183,13 +183,13 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C ! This call to set_up_sponge_ML_density registers the target values of the ! mixed layer density, which is used in determining which layers can be ! inflated without causing static instabilities. - do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo + do i=is,ie ; pres(i) = tv%P_Ref ; enddo EOSdom(:) = EOS_domain(G%HI) do j=js,je - call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), tv%eqn_of_state, EOSdom) + call calculate_density(T(:,j,1), S(:,j,1), pres, rho(:,j), tv%eqn_of_state, EOSdom) enddo - call set_up_sponge_ML_density(tmp, G, CSp) + call set_up_sponge_ML_density(rho, G, CSp) endif ! Apply sponge in tracer fields