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/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 18687a1616..a8a5ea3e68 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -222,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)" @@ -661,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)) @@ -702,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 '{}' \; ; \ @@ -721,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 04204bd67f..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 diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index e142c64ff8..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 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 c4ef8475a9..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 diff --git a/config_src/drivers/timing_tests/time_MOM_remapping.F90 b/config_src/drivers/timing_tests/time_MOM_remapping.F90 index 5f4c0258ca..e4bea9d94f 100644 --- a/config_src/drivers/timing_tests/time_MOM_remapping.F90 +++ b/config_src/drivers/timing_tests/time_MOM_remapping.F90 @@ -17,8 +17,9 @@ program time_MOM_remapping 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] +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 @@ -50,6 +51,7 @@ program time_MOM_remapping 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. @@ -59,7 +61,8 @@ program time_MOM_remapping do isamp = 1, nsamp ! Time reconstruction + remapping do ischeme = 1, nschemes - call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme))) + 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() diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 0ae5fb1e92..bc3099d68d 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -181,6 +181,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) 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 "// & @@ -248,20 +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, & om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - answer_date=CS%answer_date) + 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, & om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - answer_date=CS%answer_date) + 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 "//& @@ -345,7 +356,7 @@ 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 ) + call remapping_set_param(CS%remapCS, om4_remap_via_sub_cells=om4_remap_via_sub_cells ) end subroutine ALE_set_OM4_remap_algorithm @@ -591,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) @@ -653,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 @@ -680,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) @@ -704,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 @@ -763,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 @@ -771,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 @@ -803,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! @@ -1091,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 @@ -1099,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. @@ -1120,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) @@ -1146,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) @@ -1300,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 @@ -1319,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 @@ -1371,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_remapping.F90 b/src/ALE/MOM_remapping.F90 index 4495e4a170..3c2c0af6df 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -40,6 +40,13 @@ module MOM_remapping !> 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 @@ -114,7 +121,8 @@ 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, & - om4_remap_via_sub_cells, answers_2018, answer_date) + 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 @@ -124,6 +132,12 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & 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 ) @@ -153,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 @@ -181,7 +201,7 @@ end subroutine extract_member_remapping_CS !! !! \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, h_neglect, h_neglect_edge, net_err, PCM_cell) +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] @@ -189,12 +209,6 @@ 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. @@ -217,14 +231,10 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg 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 - 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%om4_remap_via_sub_cells) then @@ -284,7 +294,7 @@ 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] @@ -292,12 +302,7 @@ 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] @@ -317,15 +322,11 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed 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) @@ -377,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 @@ -426,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 @@ -434,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 ) @@ -460,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 ) @@ -470,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 ) @@ -1483,7 +1488,8 @@ end subroutine dzFromH1H2 !> Constructor for remapping control structure subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & check_reconstruction, check_remapping, force_bounds_in_subcell, & - om4_remap_via_sub_cells, answers_2018, answer_date) + 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 @@ -1494,12 +1500,17 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & 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, & - om4_remap_via_sub_cells=om4_remap_via_sub_cells, answers_2018=answers_2018, answer_date=answer_date) + 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 @@ -1580,21 +1591,17 @@ logical function remapping_unit_tests(verbose) 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 - 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] type(testing) :: test ! Unit testing convenience functions - integer :: om4 + integer :: i, om4 character(len=4) :: om4_tag call test%set( verbose=verbose ) ! Sets the verbosity flag in test 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 if (verbose) write(test%stdout,*) ' ===== MOM_remapping: remapping_unit_tests =================' @@ -1603,7 +1610,8 @@ logical function remapping_unit_tests(verbose) if (verbose) write(test%stdout,*) ' - - - - - 1st generation tests - - - - -' - call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date) + call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Profile 0: 4 layers of thickness 0.75 and total depth 3, with du/dz=8 n0 = 4 @@ -1623,7 +1631,7 @@ logical function remapping_unit_tests(verbose) ! Mapping u1 from h1 to h2 call dzFromH1H2( n0, h0, n1, h1, dx1 ) - call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1, h_neglect, h_neglect_edge) + 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') allocate(ppoly0_E(n0,2), ppoly0_S(n0,2), ppoly0_coefs(n0,CS%degree+1)) @@ -2067,7 +2075,7 @@ logical function remapping_unit_tests(verbose) 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) + 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 @@ -2079,27 +2087,27 @@ logical function remapping_unit_tests(verbose) endif ! Unchanged grid - call remapping_core_h( CS, n0, h0, u0, 8, [0.,1.,1.,1.,1.,1.,0.,0.], u1, 1.e-17, 1.e-2) + 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, 1.e-17, 1.e-2) + 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, 1.e-17, 1.e-2) + 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, 1.e-17, 1.e-2) + 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, 1.e-17, 1.e-2) + 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, 1.e-17, 1.e-2) + 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 @@ -2107,7 +2115,7 @@ logical function remapping_unit_tests(verbose) 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, 1.e-17, 1.e-2) + 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 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 ca5f1316c1..370a59c3c7 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -113,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 @@ -771,7 +772,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 @@ -1925,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 @@ -1952,7 +1953,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 @@ -2339,7 +2340,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 "//& @@ -2694,6 +2695,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 diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 0ac3e52a62..af2beca1fb 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -289,7 +289,7 @@ 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_fix !< If true, use a normalized wt_[uv] for vertical averages. + 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. @@ -1070,7 +1070,7 @@ 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 (CS%wt_uv_fix) then + 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) @@ -4652,11 +4652,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 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_FIX", CS%wt_uv_fix, & - "If true, use a normalized weight function for vertical averages of "//& - "baroclinic velocity and forcing. Default of this flag is set by "//& - "VISC_REM_BUG. This flag should be used with VISC_REM_TIMESTEP_FIX.", & - default=.not.visc_rem_bug) + 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 diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 5fbf12a0d0..db60b2f0e4 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -64,9 +64,6 @@ module MOM_continuity_PPM !! continuity solver for use as the weights in the !! barotropic solver. Otherwise use the transport !! averaged areas. - logical :: visc_rem_hvel_fix = .False. !< If true, thickness at velocity points - !! h_[uv] (used by barotropic solver) is not multiplied - !! by visc_rem_[uv]. end type continuity_PPM_CS !> A container for loop bounds @@ -809,22 +806,12 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa endif if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then - if (CS%visc_rem_hvel_fix) then - if (present(u_cor)) then - call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU) - else - call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU) - endif + if (present(u_cor)) then + call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) else - if (present(u_cor)) then - call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) - else - call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) - endif + call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) endif endif ; endif @@ -1709,22 +1696,12 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p endif if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then - if (CS%visc_rem_hvel_fix) 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) - 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) - endif + 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) else - 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) - 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) - endif + 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) endif endif ; endif @@ -2713,7 +2690,6 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) !> This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_continuity_PPM" ! This module's name. - logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. CS%initialized = .true. @@ -2774,11 +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.) - 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_CONT_HVEL_FIX", CS%visc_rem_hvel_fix, & - "If true, velocity cell thickness h_[uv] from the continuity solver "//& - "is not multiplied by visc_rem_[uv]. Default of this flag is set by "//& - "VISC_REM_BUG.", default=.False.) !, default=.not.visc_rem_bug) CS%diag => diag id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index addfb0e212..f602b65240 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -178,7 +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_fix = .false. !@{ Diagnostic IDs integer :: id_uold = -1, id_vold = -1 @@ -736,10 +737,10 @@ 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 - if (CS%visc_rem_dt_fix) then - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) - else + 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) @@ -1439,16 +1440,14 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p 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 three places. This parameter controls the defaults of three individual "//& - "flags, VISC_REM_TIMESTEP_FIX in MOM_dynamics_split_RK2(b), "//& - "VISC_REM_BT_WEIGHT_FIX in MOM_barotropic, and VISC_REM_CONT_HVEL_FIX in "//& - "MOM_continuity_PPM. Eventually, the three individual flags should be removed "//& - "after tests and the default of VISC_REM_BUG should be to False.", default=.true.) - call get_param(param_file, mdl, "VISC_REM_TIMESTEP_FIX", CS%visc_rem_dt_fix, & - "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& - "predictor stage for the following continuity() call and btstep() call "//& - "in the corrector step. This flag should be used with "//& - "VISC_REM_BT_WEIGHT_FIX.", default=.not.visc_rem_bug) + "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) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index 9227ea57ed..87e46795b5 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -175,7 +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_fix = .false. !@{ Diagnostic IDs ! integer :: id_uold = -1, id_vold = -1 @@ -754,10 +755,10 @@ 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 - if (CS%visc_rem_dt_fix) then - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) - else + 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) @@ -1355,16 +1356,15 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, 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 three places. This parameter controls the defaults of three individual "//& - "flags, VISC_REM_TIMESTEP_FIX in MOM_dynamics_split_RK2(b), "//& - "VISC_REM_BT_WEIGHT_FIX in MOM_barotropic, and VISC_REM_CONT_HVEL_FIX in "//& - "MOM_continuity_PPM. Eventually, the three individual flags should be removed "//& - "after tests and the default of VISC_REM_BUG should be to False.", default=.true.) - call get_param(param_file, mdl, "VISC_REM_TIMESTEP_FIX", CS%visc_rem_dt_fix, & - "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& - "predictor stage for the following continuity() call and btstep() call "//& - "in the corrector step. Default of this flag is set by VISC_REM_BUG. "//& - "This flag should be used with VISC_REM_BT_WEIGHT_FIX.", default=.not.visc_rem_bug) + "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) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index efb1bc69ab..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,9 +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 + logical :: check_remapping, force_bounds_in_subcell logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm - character(len=64) :: remappingScheme ! This include declares and sets the variable "version". # include "version_variable.h" @@ -667,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.) @@ -696,17 +705,11 @@ 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) - call get_param(param_file, mdl, "OBC_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + 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.) - allocate(OBC%remap_CS) - call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & - check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - force_bounds_in_subcell=force_bounds_in_subcell, answer_date=OBC%remap_answer_date) - endif ! OBC%number_of_segments > 0 ! Safety check @@ -729,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) @@ -1973,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 @@ -3867,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 @@ -3880,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) @@ -4176,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 @@ -4206,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 @@ -4226,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 @@ -4256,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 @@ -5528,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 @@ -5536,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. @@ -5566,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? @@ -5584,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) @@ -5594,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 @@ -5634,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? @@ -5652,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) @@ -5662,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 @@ -5861,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/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_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 705bb6e535..677fdfe6dc 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1859,7 +1859,7 @@ 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, om4_remap_via_sub_cells=om4_remap_via_sub_cells) endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 398241b98c..f5ff19630b 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -21,9 +21,9 @@ module MOM_sum_output 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 : time_type, get_time, get_date, set_time use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) -use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<), operator(>) use MOM_time_manager, only : get_calendar_type, time_type_to_real, NO_CALENDAR use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_stocks use MOM_unit_scaling, only : unit_scale_type @@ -489,7 +489,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci CS%write_energy_time = CS%Start_time + CS%energysavedays * & (1 + (day - CS%Start_time) / CS%energysavedays) endif - elseif (day + (dt_force/2) <= CS%write_energy_time) then + elseif (day + (dt_force/2) < CS%write_energy_time) then return ! Do not write this step else ! Determine the next write time before proceeding if (CS%energysave_geometric) then diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 8ee271f315..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,10 +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, & +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 @@ -1657,10 +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., & + ! 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) + 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/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index e8e6a756e9..1151cd04b2 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -313,7 +313,8 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe ! Initialize remapping and regridding on the first call call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & om4_remap_via_sub_cells=remap_cs%om4_remap_via_sub_cells, & - answer_date=remap_cs%answer_date) + answer_date=remap_cs%answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) remap_cs%initialized = .true. endif @@ -432,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. @@ -453,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 @@ -470,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 @@ -485,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/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index e8efc7c71a..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 @@ -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) @@ -2758,8 +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 + 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 ) + 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 @@ -2774,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) ) @@ -2799,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 @@ -3106,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 bafa5d8c36..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,9 @@ 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 @@ -117,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 "//& @@ -178,9 +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 + ! 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 ) + 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 @@ -206,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 9275555afc..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 @@ -184,6 +184,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) 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) @@ -244,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, & @@ -323,8 +324,15 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) 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, om4_remap_via_sub_cells=om4_remap_via_sub_cells) + + 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 @@ -415,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 @@ -427,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 @@ -443,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 @@ -683,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 @@ -700,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 diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index 94d09554c2..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 @@ -144,6 +145,7 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re 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 "// & @@ -183,22 +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 @@ -239,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, & - om4_remap_via_sub_cells=om4_remap_via_sub_cells, 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 @@ -347,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 @@ -359,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) @@ -404,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) @@ -417,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) @@ -456,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) @@ -492,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) @@ -554,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 @@ -578,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) @@ -621,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) @@ -633,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) @@ -680,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) @@ -718,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 9ebe8ae734..4bac09b7cc 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -124,6 +124,7 @@ 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 @@ -400,6 +401,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h 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) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie @@ -757,7 +765,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) @@ -1425,6 +1434,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, & @@ -1531,6 +1543,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. @@ -1538,6 +1551,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 @@ -1548,8 +1567,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 @@ -1839,6 +1860,7 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) 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 @@ -1853,6 +1875,7 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) 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 @@ -1884,6 +1907,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, & @@ -1918,6 +1947,7 @@ subroutine MEKE_end(MEKE) 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 diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90 index a95578848d..38bdd72452 100644 --- a/src/parameterizations/lateral/MOM_MEKE_types.F90 +++ b/src/parameterizations/lateral/MOM_MEKE_types.F90 @@ -24,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 56a359857f..92794c54e7 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -446,6 +446,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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 @@ -502,6 +503,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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)) & @@ -663,7 +665,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, !$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, & @@ -1181,14 +1183,26 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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) * VarMix%BS_struct(i,j,k) - 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) * VarMix%BS_struct(i,j,k) - 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 @@ -1443,7 +1457,11 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (visc_limit_h_flag(i,j,k) > 0) then Kh_BS(i,j) = 0. else - Kh_BS(i,j) = MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) + 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 @@ -1618,10 +1636,17 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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)*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 + 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) & @@ -1789,10 +1814,17 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (visc_limit_q_flag(I,J,k) > 0) then Kh_BS(I,J) = 0. else - 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))) ) + 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 @@ -2109,7 +2141,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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. @@ -2300,6 +2332,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 @@ -2331,13 +2364,23 @@ 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, & @@ -2393,8 +2436,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., & diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index f75707e581..c7101ac6b7 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -146,6 +146,7 @@ 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 :: 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] @@ -1653,7 +1654,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 ! 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) = TKE_loss * TKE_to_Kd_lim * profile_leak(i,k) * h(i,j,k) + 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 @@ -1675,7 +1676,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 ! 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) = TKE_loss * TKE_to_Kd_lim * profile_Froude(i,k) * h(i,j,k) + 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 @@ -1697,7 +1698,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 ! 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) = TKE_loss * TKE_to_Kd_lim * profile_itidal(i,k) * h(i,j,k) + 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 @@ -1719,7 +1720,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 ! 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) = TKE_loss * TKE_to_Kd_lim * profile_slope(i,k) * h(i,j,k) + 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 @@ -1741,7 +1742,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 ! 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) = TKE_loss * TKE_to_Kd_lim * profile_quad(i,k) * h(i,j,k) + 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 @@ -3539,6 +3540,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 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) @@ -4022,7 +4026,7 @@ 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 e3979fe35a..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,9 +122,15 @@ 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_) :: & @@ -163,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. !>@} @@ -173,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 @@ -214,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 @@ -241,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 .or. CS%BS_EBT_power>0.) 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 @@ -261,10 +282,50 @@ 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 @@ -460,6 +521,10 @@ 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 @@ -470,6 +535,80 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) 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) @@ -1260,14 +1399,37 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 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) @@ -1311,7 +1473,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) endif if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & - .or. CS%BS_EBT_power>0.) then + .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 "//& @@ -1320,8 +1482,47 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) units="m", default=-1.0, scale=GV%m_to_H) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif - allocate(CS%BS_struct(isd:ied,jsd:jed,GV%ke), source=0.0) - CS%BS_struct(:,:,:) = 1.0 + + + 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 @@ -1335,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) @@ -1418,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) @@ -1613,7 +1838,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "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, use_ebt_mode=CS%Resoln_use_ebt, & + 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, & om4_remap_via_sub_cells=om4_remap_via_sub_cells, wave_speed_tol=wave_speed_tol) @@ -1670,11 +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 .or. CS%BS_EBT_power>0.) & - 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 diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index b2f022ad18..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 @@ -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 diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 170265d27a..0dfead633c 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -215,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) @@ -468,6 +469,7 @@ 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 @@ -494,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.", & @@ -559,9 +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, & om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - answer_date=CS%remap_answer_date) + 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 @@ -950,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] @@ -961,16 +973,6 @@ 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 @@ -1038,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) @@ -1189,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 @@ -1222,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 diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9a87b085a6..d15a364267 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1203,7 +1203,7 @@ 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. !! @@ -1246,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 @@ -1273,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 @@ -2541,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_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 e241d191b2..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, diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index b6714148ea..6d8fe881d1 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -151,7 +151,8 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba ! GMM, TODO: add HBD params to control optional arguments in initialize_remapping. 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.) + 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, & @@ -739,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 @@ -753,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) @@ -855,15 +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., & - om4_remap_via_sub_cells=.true., & ! ### see fail below when using fixed remapping alg. - 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. diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 051ac446db..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] @@ -153,6 +153,7 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, 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.") @@ -197,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 "//& @@ -296,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. @@ -624,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 @@ -673,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 @@ -706,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 @@ -770,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 @@ -837,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 @@ -940,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 @@ -969,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 diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 855c6bef30..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 @@ -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) "//&